jbits.se

'************ You have to have capicom.dll downloaded and registered...
' Download and install: http://www.microsoft.com/DownLoads/details.aspx?FamilyID=860ee43a-a843-462f-abb5-ff88ea5896f6&displaylang=en
' run regsvr32 "C:\Program Files\Microsoft CAPICOM 2.1.0.2 SDK\Lib\X86\capicom.dll"

Option Explicit ' Explicit Declaration of Variables

' *** CAPICOM Constants
Const CAPICOM_CERTIFICATE_SAVE_AS_CER = 1
Const CAPICOM_CERTIFICATE_SAVE_AS_PFX = 0
Const CAPICOM_CERTIFICATE_INCLUDE_WHOLE_CHAIN = 1
Const CAPICOM_MEMORY_STORE  = 0 ' The store is a memory store. Any changes in the contents of the store are not persisted.
Const CAPICOM_LOCAL_MACHINE_STORE  = 1 ' The store is a local machine store. Local machine stores can be read/write stores only if the user has read/write permissions. If the user has read/write permissions and if the store is opened read/write, then changes in the contents of the store are persisted.
Const CAPICOM_CURRENT_USER_STORE  = 2 ' The store is a current user store. A current user store may be a read/write store. If it is, changes in the contents of the store are persisted.
Const CAPICOM_ACTIVE_DIRECTORY_USER_STORE  = 3 ' The store is an Active Directory store. Active Directory stores can be opened only in read-only mode. Certificates cannot be added to or removed from Active Directory stores.
Const CAPICOM_SMART_CARD_USER_STORE  = 4 ' Stores support smart card–based certificate stores. The store is the group of present smart cards. Introduced in CAPICOM 2.0.
Const CAPICOM_MY_STORE = "My" ' This store is used for a user's personal certificates.
Const CAPICOM_CA_STORE = "CA" ' CA store. This store is used to store intermediate CA certificates.
Const CAPICOM_ROOT_STORE = "Root" ' Root store. This store is used to store the root CA and self-signed, trusted certificates.
Const CAPICOM_OTHER_STORE = "AddressBook" ' AddressBook store. This store is used to keep the certificates of others.
Const CAPICOM_STORE_OPEN_READ_ONLY = 0

' *** Script Constants
Const Title="CertBack (c) JBjorkman 2009"
Const Version="0.9"

' *** Script variable declarations
Public IE        ' Declare Public Variable for events
Dim oStore        ' CAPICOM Store object variable

Dim strPFXPasswd
Dim strPath
Dim oFolder

Dim StatusHTML

' *** Setup CAPICOM Store object
on error resume next
Set oStore = CreateObject ("CAPICOM.Store")
if Err.Number <> 0 Then
MsgBox "CAPICOM not detected" & vbCRLF & "You have to have capicom.dll downloaded and registered, see script header for details."
Wscript.Quit(1)
End if

' *** Show browse for folder dialog to select where to save Certificates

Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0,"Select where to dump certificates",0)

If oFolder Is Nothing Then ' User clicked Cancel
Wscript.Quit
End If

strPath=oFolder.Self.Path

GetPasswd "Enter password for pfx encryption",strPFXPasswd

' *** Setup IE Window
IEGUISetup
CreateObject("WScript.Shell").AppActivate IE.Document.Title

DumpCerts CAPICOM_CURRENT_USER_STORE, CAPICOM_MY_STORE
DumpCerts CAPICOM_LOCAL_MACHINE_STORE, CAPICOM_MY_STORE
DumpCerts CAPICOM_CURRENT_USER_STORE, CAPICOM_CA_STORE
DumpCerts CAPICOM_LOCAL_MACHINE_STORE, CAPICOM_CA_STORE
DumpCerts CAPICOM_CURRENT_USER_STORE, CAPICOM_ROOT_STORE
DumpCerts CAPICOM_LOCAL_MACHINE_STORE, CAPICOM_ROOT_STORE

' *** Loop until false
CreateObject("WScript.Shell").popUp "Finished dumping certificates...",2

IE.Quit
Set oStore=Nothing
Set IE=Nothing
WScript.Quit

' ***** End of Main Program *****

' ***** Handle user closing IE Window
Sub IE_onQuit
Set oStore=Nothing
Set IE=Nothing
WScript.Quit
End Sub

' ***** Init IE GUI
Sub IEGUISetup()
Set IE = WScript.CreateObject("InternetExplorer.Application", "IE_")
IE.Navigate "about:blank"
WScript.Sleep 100
Do until IE.ReadyState = 4    ' Wait until Complete (READYSTATE_COMPLETE=4)
WScript.Sleep 100
Loop

IE.MenuBar=False
IE.ToolBar=False
IE.StatusBar=False
IE.Resizable=False
IE.AddressBar=False
IE.Width=975
IE.Height=IE.Document.ParentWindow.Screen.Height-50
IE.Left=(IE.Document.ParentWindow.Screen.Width-IE.Width)/2
IE.Top=10

IE.Document.Title = title

IE.Document.Open
IE.Document.Writeln "<html>"
IE.Document.Writeln "<head>"
IE.Document.Writeln "<title>" & title & "</title>"
IE.Document.Writeln "<meta http-equiv=""Content-Type"" content=""text/html; charset=iso-8859-1"">"
IE.Document.Writeln "<style type=""text/css"">"
IE.Document.Writeln "<!--"
IE.Document.Writeln ".Title {"
IE.Document.Writeln "    color: #FFFFFF;"
IE.Document.Writeln "    font-family: Verdana, Arial, Helvetica, sans-serif;"
IE.Document.Writeln "    font-weight: bold;"
IE.Document.Writeln "}"
IE.Document.Writeln ".def {font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9px; font-weight: bold; color: #f0f0c0; cursor: 'default';}"
IE.Document.Writeln ".status {font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9px; font-weight: bold; color: #e0e0c0; cursor: 'default';}"
IE.Document.Writeln ".private {font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9px; font-weight: bold; color: #e02020; cursor: 'default';}"
IE.Document.Writeln ".title {font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 12px; font-weight: bold; color: #ffffff; cursor: 'default';}"
IE.Document.Writeln "-->"
IE.Document.Writeln "</style>"
IE.Document.Writeln "</head>"
IE.Document.Writeln "<body bgcolor=""#204020"">"
IE.Document.Writeln "<p align=""center""Title"">" & title & " v" & version & "</p>"
IE.Document.Writeln "<SPAN name=""MainTable"" id=""MainTable"">"
IE.Document.Writeln "<table name=""MainTable"" id=""MainTable"" width=""900"" border=""0"" cellpadding=""0"" cellspacing=""0"" bgcolor=""#e0e0c0"">"
IE.Document.Writeln "  <tr bgcolor=""#406040"" valign=""top"">"
IE.Document.Writeln "    <td width=""200""><div align=""left""><span name=""LOC"" id=""LOC""def"">Location</span></div></td>"
IE.Document.Writeln "    <td width=""600""><div align=""left""><span name=""CER"" id=""CER""def"">Certificate</span></div></td>"
IE.Document.Writeln "    <td width=""100""><div align=""left""><span name=""ACT"" id=""ACT""def"">Action</span></div></td>"
IE.Document.Writeln "  </tr>"
IE.Document.Writeln "</table>"
IE.Document.Writeln "</SPAN>"
IE.Document.Writeln "<SPAN name=""Status"" id=""Status""status"">"
IE.Document.Writeln "</SPAN>"
IE.Document.Writeln "</body>"
IE.Document.Writeln "</html>"
IE.Visible = True
End Sub

' *** Sub to dump certificates
Sub DumpCerts(store,storetype)
Dim oCert
Dim strCertName
Dim strfname
Dim strCompName
Dim strDate
Dim strType

StrCompName=WScript.CreateObject("WScript.Network").ComputerName  ' Get Computername
StrDate=Year(Now) & right("0" & Month(Now),2) & right("0" & Day(Now),2) ' Get date (YYYYMMDD)

oStore.Open store,storetype, CAPICOM_STORE_OPEN_READ_ONLY

Select case store
case 0 strType="Memory-" & storetype
case 1 strType="Machine-" & storetype
case 2 strType="User-" & storetype
case 3 strType="AD-" & storetype
case 4 strType="SmartCard-" & storetype
end select

For Each oCert in oStore.Certificates
on error resume next
strCErtName="Unknown"
strCertName=left(oCert.SubjectName,instr(oCert.SubjectName,",")-1)
strCertName=replace(strCertName,"CN=","")
strCertName=replace(strCertName,"OU=","")
strCertName=replace(strCertName,"*","x")
strCertName=replace(strCertName," ","-")
strCertName=replace(strCertName,"/","-")
strCertName=replace(strCertName,"\","-")
strCertName=replace(strCertName,"""","-")
strCertName=replace(strCertName,".","-")
on error goto 0

strfname=strCompName & "-" & strDate & "_" & strType & "_" & strCertName

if oCert.HasPrivateKey then ' These certificates we have a private key for, we'll save them as pfx
IE.Document.all.item("Status").innerHTML="<SPAN class='private'>Saving: " & strfname & ".pfx</SPAN><BR>" & IE.Document.all.item("Status").innerHTML
oCert.Save strPath & "\" & strfname & ".pfx", strPFXPasswd, CAPICOM_CERTIFICATE_SAVE_AS_PFX, CAPICOM_CERTIFICATE_INCLUDE_WHOLE_CHAIN
else
IE.Document.all.item("Status").innerHTML="Saving: " & strfname & ".cer<BR>" & IE.Document.all.item("Status").innerHTML
oCert.Save strPath & "\" & strfname & ".cer",, CAPICOM_CERTIFICATE_SAVE_AS_CER
end if
Next
End Sub

Function GetPasswd( strPrompt, byref strPasswd)
Const CmplxRegExp="^.*(?=.{8,})(?=.*\d)(?=.*[a-z])(?=.*[A-Z])(?=.*[!@#$%^&+=]).*$" ' Complexity requirements regular expression
Dim oIEPwd
Dim oRegExp
Dim bFinished
Set oIEPwd = CreateObject( "InternetExplorer.Application" )
With oIEPwd
.Navigate "about:blank" : .Document.Title = strPrompt
.Toolbar = False : .Resizable = False : .StatusBar = False
.Width= 400 : .Height =150
.Left=(oIEPwd.Document.ParentWindow.Screen.Width-oIEPwd.width)\2
.Top=(oIEPwd.Document.ParentWindow.Screen.Height-oIEPwd.height)\2
End with
Do While oIEPwd.Busy
WScript.Sleep 100
Loop
oIEPwd.Document.Body.InnerHTML = "<DIV ALIGN=""center"">" & strPrompt & "<BR>" _
& "<INPUT TYPE=""password"" SIZE=""25"" ID=""Passwd""><BR>" _
& "<INPUT TYPE=""password"" SIZE=""25"" ID=""Passwd2""><BR>" _
& "<INPUT TYPE=""hidden"" ID=""OK"" NAME=""OK"" VALUE=""0"">" _
& "<INPUT TYPE=""submit"" VALUE="" OK "" OnClick=""VBScript:OK.Value=1""></DIV>"
oIEPwd.Visible = True

oIEPwd.document.all.Passwd.focus

On Error Resume Next

bFinished=False
Do
Do While oIEpWD.Document.All.OK.Value = 0
WScript.Sleep 100
If Err Then
GetPasswd=False : strPasswd="" : oIEPwd.Quit : Set oIEPwd = Nothing : Exit Function
End if
Loop
if oIEPwd.Document.All.Passwd.Value<>oIEPwd.Document.All.Passwd2.Value then
MsgBox "Passwords don't match, reenter please..." : oIEPwd.Document.All.Passwd.Value="" : oIEPwd.Document.All.Passwd2.Value="" : oIEpWD.Document.All.OK.Value=0 : oIEPwd.document.all.Passwd.focus
else
Set oRegExp = new RegExp
oRegExp.Pattern = CmplxRegExp
if oRegExp.Test(oIEPwd.Document.All.Passwd.Value) then ' Check our complexity requirements
GetPasswd = True
strPasswd=oIEPwd.Document.All.Passwd.Value
bFinished=True
else
MsgBox "Password does not meet complexity requirements, make sure it tests true against:" & vbCRLF & CmplxRegExp : oIEPwd.Document.All.Passwd.Value="" : oIEPwd.Document.All.Passwd2.Value="" : oIEpWD.Document.All.OK.Value=0 : oIEPwd.document.all.Passwd.focus

end if
end if
loop while bFinished=False

On Error Goto 0

oIEPwd.Quit
Set oIEPwd = Nothing
End Function