Export Bitlocker Recovery Keys from Active Directory

Today I've received a request from one of my colleague.


Requirement is to export bitlocker keys from AD. He's already using a vbscript from MS, but the script works in such a way that it creates output file for each computer in AD. He was executing the script manually everyday.


With some modifications, I could achieve the output to single file. Just want to share with other techies who might have similar requirement.


Here is the script.


## Use the script @ your own risk.


#Script starts here


sDate = DatePart("m", Now) & "-"
sDate = sDate & DatePart("d", Now) & "-"
sDate = sDate & DatePart("yyyy", Now) & ""
Set FS=CreateObject("Scripting.FilesystemObject")
'***********************************************************
'mention the path to save output file
'***********************************************************
Set Write = Fs.OpenTextFile ("c:\bitlocker-" & sDate & sTime & ".xls",2,True)
write.writeline "Computer Name" &  vbTab &  "AD Path  "  &  vbTab & "DateAdded & PasswordID"& vbTAB & "RecoveryGuid" & vbTab & "RecoveryPassword"
Sub ShowUsage
  Wscript.Echo "USAGE: Get-BitLockerRecoveryInfo [Optional Computer Name]"
  Wscript.Echo "If no computer name is specified, the local computer is assumed."
  WScript.Quit
  End Sub
Function HexByte(b)
      HexByte = Right("0" & Hex(b), 2)
End Function
Function ConvertOctetGuidToHexString(ByteArray)
  Dim Binary, S
  Binary = CStr(ByteArray)
  On Error Resume Next
  S = "{"
  S = S & HexByte(AscB(MidB(Binary, 4, 1)))
  S = S & HexByte(AscB(MidB(Binary, 3, 1)))
  S = S & HexByte(AscB(MidB(Binary, 2, 1)))
  S = S & HexByte(AscB(MidB(Binary, 1, 1)))
  S = S & "-" 
  S = S & HexByte(AscB(MidB(Binary, 6, 1)))
  S = S & HexByte(AscB(MidB(Binary, 5, 1)))
  S = S & "-" 
  S = S & HexByte(AscB(MidB(Binary, 8, 1)))
  S = S & HexByte(AscB(MidB(Binary, 7, 1)))
  S = S & "-" 
  S = S & HexByte(AscB(MidB(Binary, 9, 1)))
  S = S & HexByte(AscB(MidB(Binary, 10, 1)))
  S = S & "-" 
  S = S & HexByte(AscB(MidB(Binary, 11, 1)))
  S = S & HexByte(AscB(MidB(Binary, 12, 1)))
  S = S & HexByte(AscB(MidB(Binary, 13, 1)))
  S = S & HexByte(AscB(MidB(Binary, 14, 1)))
  S = S & HexByte(AscB(MidB(Binary, 15, 1)))
  S = S & HexByte(AscB(MidB(Binary, 16, 1)))
  S = S & "}"
  On Error GoTo 0
  ConvertOctetGuidToHexString = S
End Function

' --------------------------------------------------------------------------------
' Get path to Active Directory computer object associated with the computer name
' --------------------------------------------------------------------------------
Function GetStrPathToComputer(strComputerName)
    ' Uses the global catalog to find the computer in the forest
    ' Search also includes deleted computers in the tombstone
    Set objRootLDAP = GetObject("LDAP://rootDSE")
    namingContext = objRootLDAP.Get("defaultNamingContext") ' e.g. string dc=fabrikam,dc=com   
    strBase = """

    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOOBject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    strFilter = "(&(objectCategory=Computer)(cn=" &  strComputerName & "))"
    strQuery = strBase & ";" & strFilter  & ";distinguishedName;subtree"
    objCommand.CommandText = strQuery
    objCommand.Properties("Page Size") = 100
    objCommand.Properties("Timeout") = 100
    objCommand.Properties("Cache Results") = False
    ' Enumerate all objects found.
    Set objRecordSet = objCommand.Execute
    If objRecordSet.EOF Then
      WScript.echo "The computer name '" &  strComputerName & "' cannot be found."
      WScript.Quit 1
    End If
    ' Found object matching name
    Do Until objRecordSet.EOF
      dnFound = objRecordSet.Fields("distinguishedName")
      GetStrPathToComputer = "LDAP://" & dnFound
      objRecordSet.MoveNext
    Loop

    ' Clean up.
    Set objConnection = Nothing
    Set objCommand = Nothing
    Set objRecordSet = Nothing
End Function
TAB  = CHR( 9 )
CRLF = CHR( 13 ) & CHR( 10 )
Const ADS_SECURE_AUTHENTICATION = 1
Const ADS_USE_SEALING = 64 '0x40
Const ADS_USE_SIGNING = 128 '0x80
Const ADS_SCOPE_SUBTREE = 2
Set objConnection1 = CreateObject("ADODB.Connection")
Set objCommand1 = CreateObject("ADODB.Command")
objConnection1.Provider = "ADsDSOObject"
objConnection1.Open "Active Directory Provider"
Set objCOmmand1.ActiveConnection = objConnection1
objCommand1.CommandText = _
"Select Name, Location from 'LDAP://OU=test,DC=cxx,DC=com' " _ ' ============Mention LDAP OU PATH HERE===================='
& "Where objectCategory='computer'"
objCommand1.Properties("Page Size") = 1000
objCommand1.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRecordSet1 = objCommand1.Execute
objRecordSet1.MoveFirst
Do Until objRecordSet1.EOF
  ' --------------------------------------------------------------------------------
  ' Parse Arguments
  ' --------------------------------------------------------------------------------
  Set args = WScript.Arguments
  Select Case args.Count
 
   Case 0
    ' Get the name of the local computer     
    strComputerName =objRecordSet1.Fields("Name").Value
   
   Case 1
   If args(0) = "/?" Or args(0) = "-?" Then
      ShowUsage
   Else
     strComputerName = args(0)
   End If
 
  Case Else
    ShowUsage
End Select
' --------------------------------------------------------------------------------
' Helper function: Convert the octet GUID string (byte array) to a hex string
' --------------------------------------------------------------------------------
'Reference: http://blogs.msdn.com/ericlippert/archive/2004/05/25/141525.aspx

' --------------------------------------------------------------------------------
' Securely access the Active Directory computer object using Kerberos
' --------------------------------------------------------------------------------

Set objDSO = GetObject("LDAP:")
strPathToComputer = GetStrPathToComputer(strComputerName)
Set objFveInfos = objDSO.OpenDSObject(strPathToComputer, vbNullString, vbNullString, _
                                   ADS_SECURE_AUTHENTICATION + ADS_USE_SEALING + ADS_USE_SIGNING)

objFveInfos.Filter = Array("msFVE-RecoveryInformation")
' Iterate through each recovery information object

dim row
row = 0
For Each objFveInfo in objFveInfos
 strName = objFveInfo.Get("name")
 
   strRecoveryGuidOctet = objFveInfo.Get("msFVE-RecoveryGuid")
  
   strRecoveryGuid = ConvertOctetGuidToHexString(strRecoveryGuidOctet)

   strRecoveryPassword = objFveInfo.Get("msFVE-RecoveryPassword")

   write.WriteLine strComputerName &  vbTab &  strPathToComputer &  vbTab & strName & vbTab & strRecoveryGuid & vbTab & strRecoveryPassword

   If len(strRecoveryGuid) <> 38 Then
      WScript.echo "WARNING: '" & strRecoveryGuid & "' does not appear to be a valid GUID."
   End If
Next
'WScript.Quit  ''''''''''''''''''''''''''''''''''''''''''

Set strComputerName = Nothing
objRecordSet1.MoveNext
Loop
WScript.Quit