The WinOps Blog

public certificatesubject="AUTHENTIFICATION"
public xmlnsvalue="http://webservice.groupdirectorycertificate.com"

'==========================================================================
'    Name: GetWebService
'     Param:     samaccountname: username User
'==========================================================================
function GetWebService(StrAction,samaccountname)
    '--- Local Variable
    Dim messageSoap,xmlHttp,myFSO,WriteXmlCertificate
   
    messageSoap = "<s:Envelope xmlns:s=""http://schemas.xmlsoap.org/soap/envelope/""><s:Body xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:xsd=""http://www.w3.org/2001/XMLSchema""><getPersonCertificatesByusername xmlns=" & xmlnsvalue & "><login>" & clogin & "</login><password>"& cpassword & "</password><username>"& samaccountname & "</username></getPersonCertificatesByusername></s:Body></s:Envelope>"
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.3.0")
    xmlhttp.open "POST", cWebserviceUri , False
    xmlhttp.setRequestHeader "Content-Type", "text/xml"
    xmlhttp.setRequestHeader "SOAPAction ",""""""
    xmlhttp.send messageSoap

    Set myFSO = CreateObject("Scripting.FileSystemObject")
    If Not myFSO.FolderExists(VbsPath & cFolderNameForXmlWebservice) Then
        myFSO.CreateFolder(VbsPath & cFolderNameForXmlWebservice)
         If cBoolDebug = True Then
            WScript.Echo "Create Sub folder for xml webservice file"
        End If
    End If
    wscript.echo "Create XML for user : " & samaccountname
    Set WriteXmlCertificate= myFSO.OpenTextFile(VbsPath & cFolderNameForXmlWebservice & samaccountname & ".xml", 2, True)
    WriteXmlCertificate.WriteLine(xmlhttp.responseXML.xml)
    WriteXmlCertificate.Close
    UserusernameProcessing = samaccountname
    XmlRead StrAction,samaccountname
    Set WriteXmlCertificate = Nothing
    Set myFSO = Nothing
    Set xmlHttp = Nothing
End Sub

'Read xml file
function XmlRead(StrAction,pStrUserusernameXml)
    '--Local Variable
    Dim objItem,colItem,oElement
    Dim xmlDoc,fso,itemElement,WriteCertCertificate,icptCertificat
    Set xmlDoc = CreateObject("Microsoft.XMLDOM")
    Set fso = createobject("Scripting.FileSystemObject")
    xmlDoc.Async = "False"
   
    If  fso.FileExists(VbsPath & cFolderNameForXmlWebservice & pStrUserusernameXml & ".xml") Then
        objWritelogApplication.SetExecutionName= "Certificate XML Read"
        wscript.echo "File Xml Found: " & pStrUserusernameXml & ".xml"
        xmlDoc.Load(VbsPath & cFolderNameForXmlWebservice & pStrUserusernameXml& ".xml")
        Set oElement = xmlDoc.documentElement
           If Not oElement Is Nothing Then
              
               If oElement.getElementsByTagName("p499:getPersonCertificatesByusernameReturn").length > 0 Then
                   If Not fso.FolderExists(VbsPath & cFolderNameForCert) Then
                    fso.CreateFolder(VbsPath & cFolderNameForCert)
                     If cBoolDebug = True Then
                        WScript.Echo "Create Sub folder for Cert tempory file"
                       End If
                End If
                icptCertificat = 1
                For Each itemElement In oElement.getElementsByTagName("p499:getPersonCertificatesByusernameReturn")
                       Set WriteCertCertificate= fso.OpenTextFile(VbsPath & cFolderNameForCert & pStrUserusernameXml & "-"& icptCertificat & ".cer", 2, True)
                       wscript.echo "certificat value: " & itemElement.text
                    WriteCertCertificate.WriteLine(itemElement.text)
                    WriteCertCertificate.Close
                    Set WriteCertCertificate = Nothing
                    GetInformationFromCertificate StrAction,VbsPath & cFolderNameForCert & pStrUserusernameXml & "-"& icptCertificat & ".cer"
                    icptCertificat = icptCertificat + 1
                Next
            Else
                wscript.echo "User Not found in WebServices: " & pStrUserusernameXml
                For Each itemElement In oElement.getElementsByTagName("p521:message")
                   wscript.echo "Error: " & itemElement.text
                Next   
            End If
        Else
            wscript.echo "File Xml null: " & pStrUserusernameXml & ".xml"
        End If
       Else
        wscript.echo "Xml Configuration File not found: " & VbsPath & cFolderNameForXmlWebservice & pStrUserusernameXml & ".xml"
    End If
End Sub

'Read certificate
function GetInformationFromCertificate(StrAction,pcertificatStringPath)
    On Error Resume Next
    Dim Certificate
    Dim CertFile
    Dim Chain,CheckFlag

    'Set Object
    Set Certificate = CreateObject("CAPICOM.Certificate")
    If Err.Number <> 0 Then
        wscript.echo Err.Description & ":" & pcertificatStringPath
        Err.Clear
        WScript.Quit -1
    End If
        wscript.echo "Load the certificate" & ":" & pcertificatStringPath
        Certificate.Load (pcertificatStringPath), ""
    Set Chain = CreateObject("CAPICOM.Chain")
    If Err.Number <> 0 Then
        wscript.echo Err.Description & ":" & pcertificatStringPath
        Err.Clear
        WScript.Quit -1
    End If
    If Not IsNull(CheckFlag) Then
        Certificate.IsValid.CheckFlag = CheckFlag
    End If
   
   
    If Chain.Build(Certificate) Then
       wscript.echo "The overall chain status is valid: " & pcertificatStringPath
    Else
       wscript.echo "The overall chain status is not valid: " & pcertificatStringPath
       wscript.echo "Overall chain status code  = 0x" & Hex(Chain.Status) & " (" & GetStatusString(Chain.Status) & ")"
       wscript.echo "Extended error information = " & Chain.ExtendedErrorInfo
    End If
   
   
    If Not IsNull(CheckFlag) Then
       Dim cIndex
       For cIndex = 1 to Chain.Certificates.Count
       wscript.echo "Display the current certificate."
          DisplayCertificate StrAction,Chain, cIndex
       Next
    Else
       wscript.echo "Display the end of certificate."
       DisplayCertificate StrAction,Chain, 1
     
    End If
    Set Certificate = Nothing
    Set Chain = Nothing
End Sub

Sub DisplayCertificate (StrAction,Chain, cIndex)
    On Error Resume Next
 
 
   Dim Certificate,arrTempSubjectName,icptitem,InformationAltsecurity
   Dim TempSubjectReverse, TempISSUERReverse,arrTempISSUER
 
   Set Certificate = Chain.Certificates.Item(cIndex)
   If InStr(Certificate.SubjectName,certificatesubject) > 0 Then
       wscript.echo "SubjectName: " & Certificate.SubjectName
      
       arrTempSubjectName = Split(Certificate.SubjectName,",")
       arrTempISSUER = Split(Certificate.IssuerName,",")
       For icptitem = UBound(arrTempISSUER) To 0 Step -1
            If (icptitem <> 0) Then
                TempISSUERReverse = TempISSUERReverse &  ltrim(arrTempISSUER(icptitem)) & ","
            Else
                TempISSUERReverse = TempISSUERReverse &  ltrim(arrTempISSUER(icptitem))
            End If          
       Next
       For icptitem = UBound(arrTempSubjectName) To 0 Step -1
            If (icptitem) <> 0 Then
                TempSubjectReverse = TempSubjectReverse &  ltrim(arrTempSubjectName(icptitem)) & ","
            Else
                TempSubjectReverse = TempSubjectReverse &  ltrim(arrTempSubjectName(icptitem))
            End If
       Next
       InformationAltsecurity = "X509:<l>" & TempISSUERReverse & "<S>" & TempSubjectReverse
        wscript.echo "--------------------------------"
        wscript.echo "SubjectName: " & InformationAltsecurity
        wscript.echo "--------------------------------"
        setValueToAdd StrAction,UserusernameProcessing,Null,InformationAltsecurity
        if not instr(lcase(StrAction),lcase("clear"))>0 then
            if isnull(TempISSUERReverse) = true or isnull(TempSubjectReverse) = true _
            or TempISSUERReverse = "" or TempSubjectReverse = "" _
            or instr(lcase(TempSubjectReverse),lcase(UserusernameProcessing)) = 0 then
            wscript.echo "InformationAltsecurity for username " & UserusernameProcessing & " is not valid"
            else
            wscript.echo "InformationAltsecurity for username " & UserusernameProcessing & " = " & InformationAltsecurity
            end if
        end if
   Else
    wscript.echo "The certificat is not valid for username " & UserusernameProcessing
   End If
 
End Sub

function GetListOfUserWhereAltSecurityIsnotNull(pOrganizationUnit)
     On Error Resume Next
     '--- Local Variable
     Dim adoCommand, adoConnection, strBase, strAttributes
     Dim strDNSDomain, strQuery, adoRecordset, strDistinguedNAme, strCN,objRootDSE,strFilter

'--- Setup ADO objects.
     Set adoCommand = CreateObject("ADODB.Command")
     Set adoConnection = CreateObject("ADODB.Connection")
     adoConnection.Provider = "ADsDSOObject"
     adoConnection.Open "Active Directory Provider"
     Set adoCommand.ActiveConnection = adoConnection
   
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strDNSDomain = objRootDSE.Get("defaultNamingContext")
        If IsNull(pOrganizationUnit) Then
             strBase = strDNSDomain
         Else
             strBase = "<LDAP://" & pOrganizationUnit & "," & strDNSDomain & ">"
        End If
     ' Filter on user objects.
     strFilter = "(&(objectCategory=user)(objectClass=user)(!altSecurityIdentities=*))"
   
     ' Comma delimited list of attribute values to retrieve.
     strAttributes = "sAMAccountName"
   
     ' Construct the LDAP syntax query.
     strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
     adoCommand.CommandText = strQuery
     adoCommand.Properties("Page Size") = 100
     adoCommand.Properties("Timeout") = 30
     adoCommand.Properties("Cache Results") = False
   
     ' Run the query.
     Set adoRecordset = adoCommand.Execute
     wscript.echo "Active Directory Reqest: " & strFilter & "; LDAP:" & strBase
     If Err.Number <> 0 Then
        wscript.echo "Active Directory Error: " & Err.Description
        WScript.quit -1
     End If
   
     ' Enumerate the resulting recordset
     Do Until adoRecordset.EOF
        ' Retrieve values and display.
        GetWebService adoRecordset.Fields("sAMAccountName").Value
     'Move to the next record in the recordset.
     adoRecordset.MoveNext
     Loop
    ' Destruct Object
     adoRecordset.Close
     adoConnection.Close
End Sub

function IsAltSecurityIsnull(puserName)
     On Error Resume Next
     '--- Local Variable
     Dim adoCommand, adoConnection, strBase, strAttributes
     Dim strDNSDomain, strQuery, adoRecordset, strDistinguedNAme, strCN,objRootDSE,strFilter

'--- Setup ADO objects.
     Set adoCommand = CreateObject("ADODB.Command")
     Set adoConnection = CreateObject("ADODB.Connection")
     adoConnection.Provider = "ADsDSOObject"
     adoConnection.Open "Active Directory Provider"
     Set adoCommand.ActiveConnection = adoConnection
   
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strDNSDomain = objRootDSE.Get("defaultNamingContext")
             strBase =  "<LDAP://" & strDNSDomain & ">"
     ' Filter on user objects.
     strFilter = "(&(objectCategory=user)(objectClass=user)(sAMAccountName=" & puserName & "))"
   
     ' Comma delimited list of attribute values to retrieve.
     strAttributes = "distinguishedName"
   
     ' Construct the LDAP syntax query.
     strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
     adoCommand.CommandText = strQuery
     adoCommand.Properties("Page Size") = 100
     adoCommand.Properties("Timeout") = 30
     adoCommand.Properties("Cache Results") = False
   
     ' Run the query.
     Set adoRecordset = adoCommand.Execute
     wscript.echo "LDAP: " & strBase & " Filter: " & strFilter
     If Err.Number <> 0 Then
        wscript.echo "Active Directory Error: " & Err.Description
        WScript.quit -1
     End If
   
     ' Enumerate the resulting recordset
     Do Until adoRecordset.EOF
        ' Retrieve values and display.
         strDistinguedNAme = adoRecordset.Fields("distinguishedName").Value
     'Move to the next record in the recordset.
     adoRecordset.MoveNext
     Loop
    ' Destruct Object
     adoRecordset.Close
     adoConnection.Close

    IsAltSecurityIsnull = strDistinguedNAme    
End Function

function checkaltsecattrib(strUserusername)
on error resume next
Set objUser = GetObject ("LDAP://" & GetDistinguedName(strUserusername))
    objUser.GetInfo
    checkaltsecattrib = objUser.Get("altSecurityIdentities")
    if isnull(checkaltsecattrib) or checkaltsecattrib="" then
    checkaltsecattrib = ""
    end if
on error goto 0
end function

function usernameprerequisite(strUserusername)
checknomenclatureusername(strUserusername)
    if ValidstrUserusername=FALSE then
    wscript.echo "Nomenclature of username Error : '" & strUserusername & "' is wrong (good form: JXXXXXXX or LXXXXXXX), script Quit"
    WScript.quit -1
    end if
end function

'################################################### ACTION ###############################################################
function setValueToAdd(StrAction,PuserName,pstrOrganizationUnit,pValueforAltersecurity)
On Error Resume Next
'--- Local Variable
Dim oUser,myFSO,obfsoLogAction,TrueValueforAltersecurity
'Set oUser = GetObject ("LDAP://" & GetDistinguedName(PuserName,pstrOrganizationUnit))
Set oUser = GetObject ("LDAP://" & GetDistinguedName(PuserName))
 
If instr(pValueforAltersecurity,PuserName)>0 then
    TrueValueforAltersecurity=pValueforAltersecurity
end if
   
    If ucase(StrAction) = "UPDATE" _
    Or ucase(StrAction) = "CLEAR" Then
    oUser.GetInfo
    OldValue = oUser.Get("altSecurityIdentities")
    End If
   
    if ucase(StrAction) = "CLEAR" then
    'OldValue = IsAltSecurityIsnull(PuserName)
    oUser.PutEx ADS_PROPERTY_CLEAR, "altSecurityIdentities", 0
    end if
   
    if ucase(StrAction) = "UPDATE" _
    or ucase(StrAction) = "SET" _
    or ucase(StrAction) = "SET-ALL" then
    oUser.Put "altSecurityIdentities",TrueValueforAltersecurity
    end if
   
    oUser.SetInfo
        If Err.Number <> 0 Then
            if Err.Number = "-2147467259" then
            else
            wscript.echo "Active Directory Error set value for altSecurityIdentities properties: " & Err.Description
            if ucase(StrAction) = "SET-ALL" then
            wscript.echo "Next Userusername"
            else
            WScript.quit -1
            end if
            end if
        Else
            Set myFSO = CreateObject("Scripting.FileSystemObject")
            Set obfsoLogAction= myFSO.OpenTextFile(VbsPath & LogFileNameAction  & ".txt", 8, True)
                If StrAction = "UPDATE" Then
                'log : DATE|UPDATE|before;after
                    obfsoLogAction.WriteLine            Date & "|" & StrAction & "|" & OldValue & ";" & TrueValueforAltersecurity
                elseif StrAction = "CLEAR" then
                'log : DATE|CLEAR|before
                    obfsoLogAction.WriteLine            Date & "|" & StrAction & "|" & OldValue
                else
                'log : DATE|SET|after
                    obfsoLogAction.WriteLine            Date & "|" & StrAction & "|" & TrueValueforAltersecurity
                End If
                obfsoLogAction.Close
                Set obfsoLogAction = Nothing
                Set myFSO = Nothing
         End If
    Set oUser = Nothing
End Sub

function GetDistinguedName(strUserusername)
dim objUser
dim objWMI : Set objWMI = GetObject("winmgmts:\\" & strComputer & "\root\directory\LDAP")
dim objUsers : Set objUsers = objWMI.ExecQuery("SELECT * FROM ds_user where ds_sAMAccountName = '" & strUserusername & "' ")
   For Each objUser in objUsers
      GetDistinguedName = objUser.ds_distinguishedName
   Next
end function