Dim currentDirectory,Certreq
Certreq = "certreq.exe"
currentDirectory = left(WScript.ScriptFullName,(Len(WScript.ScriptFullName))-(len(WScript.ScriptName)))
''' Don't change belows this line unless you know what you doing
''' =============================================================================
'''CAPICOM_KEY_LOCATION Enumeration
Const CAPICOM_CURRENT_USER_KEY = 0 'The key is a user key.
Const CAPICOM_LOCAL_MACHINE_KEY = 1 'The key is a machine key.
Const HKEY_CLASSES_ROOT = &H80000000
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
OS = Get_OS(objWMIService)
OS_Type = Get_OS_TYPE(objWMIService)
If ( instr(UCase(OS),UCase("Windows 7")) <> 0 ) and (OS_Type="x64")Then
Script_Engine_Arch = Wscript_Engine
If (Script_Engine_Arch = "x86") or (ElevationCheck = False) Then
Set objShell = CreateObject( "WScript.Shell" )
WINDIR=objShell.ExpandEnvironmentStrings("%windir%")
colScriptBase_Engine = Split(Wscript.FullName,"\")
objScriptEngine = colScriptBase_Engine(UBound(colScriptBase_Engine))
x64ScriptEngine = WINDIR & "\SysWOW64\" & objScriptEngine
Set objelevate = CreateObject("Shell.Application")
objelevate.ShellExecute x64ScriptEngine , Chr(34) & Wscript.ScriptFullName & Chr(34) ,"","runas",1
Else
Main
End If
End If
Sub Main()
UserInfo=Inputbox("Please enter windows AD account for generating CA configuration file!","CA conf generator")
If len(UserInfo) <> 6 Then
Msgbox "Invalid Windows AD ccount",vbCritical+vbOkOnly,"Critical Error"
Wscript.Quit
Else
GetUserInfo UserInfo
End If
SetupConf Config, "[Version]"
SetupConf Config, "Signature=""$Windows NT$"""
SetupConf Config, ""
SetupConf Config, "[NewRequest]"
SetupConf Config, "Subject=""" & UserInfo & """"
SetupConf Config, "ProviderName=""Microsoft Enhanced RSA and AES Cryptographic Provider"""
SetupConf Config, "ProviderType=24"
SetupConf Config, "KeyLength=1024"
SetupConf Config, "Exportable=True"
'SetupConf Config, "Exportable=False"
SetupConf Config, "KeySpec=1"
SetupConf Config, "KeyUsage=0xf0 "
'SetupConf Config, "MachineKeySet=False"
SetupConf Config, "MachineKeySet=True"
SetupConf Config, "SMIME=True"
SetupConf Config, "RequestType=CMC"
SetupConf Config, ""
SetupConf Config, "[EnhancedKeyUsageExtension]"
SetupConf Config, "OID=1.3.6.1.5.5.7.3.2"
SetupConf Config, ""
SetupConf Config, "[RequestAttributes]"
ExportConfigFile Config
SubmitCAREQ
End Sub
Sub GetUserInfo (ByRef rtnString)
On Error Resume Next
Set WshShell = CreateObject("Wscript.Shell")
Set WshSysEnv = WshShell.Environment("PROCESS")
'sUserName=WshSysEnv("USERNAME")
sUserName=rtnString
Set rootDSE = GetObject("LDAP://RootDSE")
DomainContainer = rootDSE.Get("defaultNamingContext")
Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
ldapStr = "
Set rs = conn.Execute(ldapStr)
If rs.RecordCount <> 1 Then
Msgbox "System Error,cannot find user info on AD system",vbCritical + vbYesOnly,"System error"
Wscript.Quit 1
End If
Company = "XXXXXX"
If Trim("Santa Clara") = Trim(rs.Fields("physicalDeliveryOfficeName")) Then
Company = "XXXXXXX"
End If
Select Case UCase(rs.Fields("physicalDeliveryOfficeName"))
Case UCase("TX")
Company = "TX"
State = "TX"
Case UCase("VT")
Company = "VT"
State = "VT"
Case UCase("US")
Company = "US"
State = "CA"
End Select
rtnString = "E=" & rs.Fields("mail") &_
",CN=" & rs.Fields("cn") &_
",OU=" & rs.Fields("department") &_
",O=" & Company &_
",L=" & rs.Fields("physicalDeliveryOfficeName") &_
",S=" & State &_
",C=US"
End Sub
Sub SetupConf (ByRef Configuration, Value)
Configuration = Configuration & Value & vbCrLf
End Sub
Sub ExportConfigFile(Content)
Set objFSO = CreateObject("Scripting.FileSystemObject")
ScriptPath = Left(WScript.ScriptFullName,Len(WScript.ScriptFullName) - Len(WScript.ScriptName))
Config_Name = "MyCA.inf"
Set objTextOutStream = objFSO.CreateTextFile(ScriptPath & Config_Name)
objTextOutStream.Write Content
objTextOutStream.Close
End Sub
Sub SubmitCAREQ()
On Error Resume Next
Set WshShell = CreateObject("Wscript.Shell")
CertSVR = "FQDN_OF_CA_SERVER\CANAME"
WshShell.Exec("%ComSpec% /c certreq -New -f " & chr(34) & currentDirectory & "MyCA.inf" & chr(34) & " " & chr(34) & currentDirectory & "MyCA.req" & chr(34)).StdOut.ReadAll
rtnValue = WshShell.Exec("%ComSpec% /c certreq -Submit -f -config " & CertSVR & " " & chr(34) & currentDirectory & "MyCA.req" &chr(34)).StdOut.ReadAll
RequestId = Split(rtnValue,vbCrLf)
If UBound(RequestId) > 2 Then
DeleteUnusedFiles
Msgbox "CA request has been sent to Server" & vbCrLf &_
"Your Request ID is [" & Trim(Replace(RequestId(1),"RequestId:","")) & "]", vbYesOnly+vbInformation, "NAP-VPN CA apply assistant"
Else
Msgbox "Fail to submit CA request to server" & vbCrLf & "Error info: " & Err.Description,vbYesOnly+vbCritical, "NAP-VPN CA apply assistant"
Wscript.Quit 1
End If
End Sub
Sub DeleteUnusedFiles()
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Config_Name = "MyCA.inf"
REQ_Name = "MyCA.req"
objFSO.DeleteFile currentDirectory & Config_Name
objFSO.DeleteFile currentDirectory & REQ_Name
End Sub
Function Get_OS(ByRef objWMIService)
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)
For Each objItem in colItems
Get_OS = objItem.Caption
Next
Set colItems = Nothing
End Function
Function Get_OS_TYPE(ByRef objWMIService)
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
For Each objItem in colItems
If instr( objItem.SystemType,"64") <> 0 Then
Get_OS_TYPE = "x64"
Else
Get_OS_TYPE = "x86"
End If
Next
Set colItems = Nothing
End Function
Function Wscript_Engine()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set SystemDirectory = objFSO.GetSpecialFolder(1)
If Instr(UCase(Wscript.FullName),UCase(SystemDirectory)) <> 0 Then
Wscript_Engine = "x86"
Else
Wscript_Engine = "x64"
End If
End Function
Function ElevationCheck 'test whether user has elevated token
Dim oShell, oExecWhoami, oWhoamiOutput, strWhoamiOutput, boolHasElevatedToken
Set oShell = CreateObject("WScript.Shell")
Set oExecWhoami = oShell.Exec("whoami /groups")
Set oWhoamiOutput = oExecWhoami.StdOut
strWhoamiOutput = oWhoamiOutput.ReadAll
If InStr(1, strWhoamiOutput, "S-1-16-12288", vbTextCompare) Then boolHasElevatedToken = True
If boolHasElevatedToken Then
ElevationCheck = True
Else
ElevationCheck = False
End If
End Function
-----------------------------------------------------------------------------------------------------------------------------export
'Option Explicit
'On Error Resume next
'Dim SubjectName
Dim Store, Certificates, Certificate, SavePath, SaveExt, CertNumCounter, PrivateKeyPassword, PK, Uflag, RequestID
Dim objCertStore, objCert, currentDirectory, fso, folder, files, fileIdx, Answer1, Answer2, LatestCertificate
UFlag=false
'''CAPICOM_STORE_LOCATION Enumeration
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.
Const CAPICOM_CURRENT_USER_STORE = 2 'The store is a current user store.
Const CAPICOM_ACTIVE_DIRECTORY_USER_STORE = 3 'The store is an Active Directory store.
Const CAPICOM_SMART_CARD_USER_STORE = 4 'Stores support smart cardased certificate stores.
'''CAPICOM_CERTIFICATE_FIND_TYPE Enumeration
Const CAPICOM_CERTIFICATE_FIND_SHA1_HASH = 0 'Returns certificates matching a specified SHA1 hash.
Const CAPICOM_CERTIFICATE_FIND_SUBJECT_NAME = 1 'Returns certificates whose subject name exactly or partially matches.
Const CAPICOM_CERTIFICATE_FIND_ISSUER_NAME = 2 'Returns certificates whose issuer name exactly or partially matches.
Const CAPICOM_CERTIFICATE_FIND_ROOT_NAME = 3 'Returns certificates whose root subject name exactly or partially matches.
'''CAPICOM_STORE_OPEN_MODE Enumeration
Const CAPICOM_STORE_OPEN_READ_ONLY = 0 'Open the store in read-only mode.
Const CAPICOM_STORE_OPEN_READ_WRITE = 1 'Open the store in read/write mode.
Const CAPICOM_STORE_OPEN_MAXIMUM_ALLOWED = 2 'Open the store in read/write mode if the user has read/write permissions.
Const CAPICOM_STORE_OPEN_EXISTING_ONLY = 128 'Open existing stores only; do not create a new store. Introduced by CAPICOM 2.0.
Const CAPICOM_STORE_OPEN_INCLUDE_ARCHIVED = 256 'Include archived certificates when using the store. Introduced by CAPICOM 2.0.
'''CAPICOM_CERTIFICATE_SAVE_AS_TYPE Enumeration
Const CAPICOM_CERTIFICATE_SAVE_AS_PFX = 0 'The output file will be formatted as a PFX (PKCS 12) file and any associated private keys.
Const CAPICOM_CERTIFICATE_SAVE_AS_CER = 1 'The output file will be formatted as a CER file with no private keys saved.
'''CAPICOM_CERTIFICATE_INCLUDE_OPTION Enumeration
Const CAPICOM_CERTIFICATE_INCLUDE_CHAIN_EXCEPT_ROOT = 0 'Saves all certificates in the chain with the exception of the root entity.
Const CAPICOM_CERTIFICATE_INCLUDE_WHOLE_CHAIN = 1 'Saves the complete certificate chain.
Const CAPICOM_CERTIFICATE_INCLUDE_END_ENTITY_ONLY = 2 'Saves only the end entity certificate.
'''CAPICOM_KEY_STORAGE_FLAG Enumeration
Const CAPICOM_KEY_STORAGE_DEFAULT = 0 'Default key storage.
Const CAPICOM_KEY_STORAGE_EXPORTABLE = 1 'The key is exportable.
Const CAPICOM_KEY_STORAGE_USER_PROTECTED = 2 'The key is user protected.
'''CAPICOM_KEY_LOCATION Enumeration
Const CAPICOM_CURRENT_USER_KEY = 0 'The key is a user key.
Const CAPICOM_LOCAL_MACHINE_KEY = 1 'The key is a machine key.
Const HKEY_CLASSES_ROOT = &H80000000
Const ConfigStr = "FQDN_OF_CA\CANAME"
Const CertReq = "certreq.exe"
currentDirectory = left(WScript.ScriptFullName,(Len(WScript.ScriptFullName))-(len(WScript.ScriptName)))
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
OS = Get_OS(objWMIService)
OS_Type = Get_OS_TYPE(objWMIService)
If ( instr(UCase(OS),UCase("Windows 7")) <> 0 ) and (OS_Type="x64")Then
Script_Engine_Arch = Wscript_Engine
If (Script_Engine_Arch = "x86") or (ElevationCheck = False) Then
Set objShell = CreateObject( "WScript.Shell" )
WINDIR=objShell.ExpandEnvironmentStrings("%windir%")
colScriptBase_Engine = Split(Wscript.FullName,"\")
objScriptEngine = colScriptBase_Engine(UBound(colScriptBase_Engine))
x64ScriptEngine = WINDIR & "\SysWOW64\" & objScriptEngine
Set objelevate = CreateObject("Shell.Application")
objelevate.ShellExecute x64ScriptEngine , Chr(34) & Wscript.ScriptFullName & Chr(34) ,"","runas",1
Else
Main
End If
End If
'''\\\\\\\ Sub Functions \\\\\\\\\
'''
Sub Main
RequestID = InputBox("Enter your Certificate RequestID:", "Cert Export & Import for NAP-VPN")
If RequestID="" Then
Wscript.Quit
End If
If isnumeric(RequestID) <> True Then
Msgbox "RequestID must be numeric",vbOkOnly + vbCritical, "rtn Code"
Wscript.Quit 1
End If
'SavePath = "ntcusa"
SaveExt = ".pfx"
PK = "Private"
CertNumCounter = 0
PackageCheck
Retrieve_CER
Install_CER
PrivateKeyPassword = "ntcusa"
'''''RegisterCapicom
ExportCert
'InsertCert
End Sub
Sub PackageCheck()
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(objFSO.GetSpecialFolder(1) & "\" & Certreq) = False Then
objFSO.CopyFile currentDirectory & CertReq , objFSO.GetSpecialFolder(1) & "\"
End If
If err.number <> 0 Then
Msgbox "Fail to install certreq to system!",vbOkOnly + vbCritical, "Certreq error code"
Wscript.Quit 1
End If
Set objFSO = nothing
End Sub
Sub Retrieve_CER
On Error Resume Next
Set WshShell = CreateObject("Wscript.Shell")
rtnValue = WshShell.Exec("%ComSpec% /c certreq -f -config " & ConfigStr & " -retrieve " & RequestID & " " & chr(34) & currentDirectory & PK & ".cer" & chr(34)).StdOut.ReadAll
If instr(rtnValue ,"pending") <> 0 Then
Msgbox "Please call system admin to issue the certificate for you!",vbOkOnly + vbCritical, "Certificate retrieve info"
Wscript.Quit 1
End If
If instr(rtnValue ,"Issued") = 0 Then
Msgbox "Fail to retrieve certificate",vbOkOnly + vbCritical, "Certificate retrieve info"
Wscript.Quit 1
End If
Set WshShell = nothing
End Sub
Sub Install_CER
On Error Resume Next
Set WshShell = CreateObject("Wscript.Shell")
rtnValue = WshShell.Exec("%ComSpec% /c certreq -accept " & chr(34) & currentDirectory & PK & ".cer" & chr(34)).StdOut.ReadAll
DeleteUnusedFiles (currentDirectory & PK & ".cer")
If instr(rtnValue , "Cannot find object or property.") Then
Msgbox "Private key cannot match this certificate." & vbCrLf & "Please resubmit your CA request again.",vbCritical + vbOkOnly,"Certificate import result"
Wscript.Quit 1
End If
Set WshShell = nothing
End Sub
'''\\\\\\\\ This subfunction is for certificate export \\\\\\\\\''
Sub ExportCert
On Error Resume Next
Set Store = CreateObject("CAPICOM.Store")
'''Test Capicom.dll exist of not base on vb error handling
If err.number = 0 Then
'OK, Capicom.dll was registered; do nothing here...
ElseIf err.number = 429 Then
'WScript.Echo "Capicom was registered, but CAPICOM.store object still cannot be created..."
MsgBox("CAPICOM.DLL was registered, but CAPICOM.store object" & VbCrLf & "still cannot be created..." & VbCrLf & "Please contact your local admin")
err.Clear
WScript.Quit 1
Else
'wscript.echo "Unknown error. Error#: " & err.number
MsgBox("Unknown error. Error#: " & err.number & VbCrLf & "Please contact your local admin")
err.clear
WScript.Quit 1 'Terminate script when unknown error occurs...
End If
If isNull(Store) Then
'WScript.Echo "Store object cannot be created; error#: " & err.number
MsgBox("Store object cannot be created. error#: " & err.number & VbCrLf & "Please contact your local admin")
WScript.Quit 1
End If
Store.Open CAPICOM_LOCAL_MACHINE_STORE, "MY" , CAPICOM_STORE_OPEN_READ_WRITE 'CAPICOM_STORE_OPEN_READ_ONLY
'Set Certificates = Store.Certificates.Find(CAPICOM_CERTIFICATE_FIND_SUBJECT_NAME, SubjectName, false)
Set Certificates = Store.Certificates.Find(CAPICOM_CERTIFICATE_FIND_ISSUER_NAME, "us-NTCSJNT35-CA", false)
If Certificates.Count > 0 Then
For Each Certificate in Certificates
If DateDiff("s",now,Certificate.ValidToDate)<0 Then ' remove expired certificate
Store.remove Certificate
Else
If Certificate.HasPrivateKey Then ' Private Key
If Certificate.PrivateKey.IsExportable Then
If ExtractCertInfo(Certificate) = True Then
Set LatestCertificate = Certificate
UFlag = True
Exit For
End If
Else 'non-exportable key
'Store.remove Certificate
End If
Else 'non-private key
Store.remove Certificate
End If
End If
Next
Else
MsgBox("No applied certificates could be found on your system")
WScript.Quit 1
End If
If UFlag Then
colSubject=Split(LatestCertificate.SubjectName,",")
State = Split(colSubject(5),"=")(1)
AppliedUser=Split(colSubject(1),"=")(1)
LatestCertificate.Save currentDirectory & State & " - " & AppliedUser & SaveExt, PrivateKeyPassword, CAPICOM_CERTIFICATE_SAVE_AS_PFX, CAPICOM_CERTIFICATE_INCLUDE_CHAIN_EXCEPT_ROOT
Store.remove LatestCertificate
'Remove Key here
Else
MsgBox("Warnning!! No valid certificate could be found." & VbCrLf & "Please re-enroll with and check the check box 'Mark keys as exportable'.")
End If
Set Certificates = Nothing
Set Store = Nothing
Wscript.Echo "Done"
End Sub
Function ExtractCertInfo(Certificate)
'Wscript.Echo Certificate.SubjectName & vbCrLf & "Valid From : [" & Certificate.ValidFromDate & "] Valid To : [" & Certificate.ValidToDate & "]"
colSubject=Split(Certificate.SubjectName,",")
msg = msg & "Do you want to export this certificate!" & vbCrLf & vbCrLf
msg = msg & "Valid From : [" & Certificate.ValidFromDate & "]" & vbCrLf
msg = msg & "Valid To : [" & Certificate.ValidToDate & "]" & vbCrLf
msg = msg & vbCrLf
msg = msg & Replace(Trim(colSubject(0)),"E=","Email Address : ") & vbCrLf
msg = msg & Replace(Trim(colSubject(1)),"CN=","User Name : ") & vbCrLf
msg = msg & Replace(Trim(colSubject(2)),"OU=","Department : ") & vbCrLf
msg = msg & Replace(Trim(colSubject(3)),"O=","Organization : ") & vbCrLf
msg = msg & Replace(Trim(colSubject(4)),"L=","City : ") & vbCrLf
msg = msg & Replace(Trim(colSubject(5)),"S=","State :") & vbCrLf
msg = msg & Replace(Trim(colSubject(6)),"C=","Country : ") & vbCrLf
rtnValue =Msgbox(msg , vbInformation + vbYesNo, "Certificate Information")
If rtnValue = vbYes Then
ExtractCertInfo = True
Else
ExtractCertInfo = False
End If
End Function
'''\\\\\\\\ This sub function is for certificate import action\\\\\\\\\''
Sub InsertCert
On Error Resume next
set objCertStore = CreateObject ("CAPICOM.Store")
set objCert = CreateObject ("CAPICOM.Certificate")
currentDirectory = left(WScript.ScriptFullName,(Len(WScript.ScriptFullName))-(len(WScript.ScriptName)))
objCertStore.Open CAPICOM_LOCAL_MACHINE_STORE, "My", CAPICOM_STORE_OPEN_READ_WRITE
objCert.Load currentDirectory & PK & SaveExt, PrivateKeyPassword, CAPICOM_KEY_STORAGE_DEFAULT, CAPICOM_LOCAL_MACHINE_KEY
objCertStore.Add objCert
If err.number = 0 Then
DeleteUnusedFiles PK & SaveExt
MSgbox "Complete to install NAPVPN certificate on your Machine",vbOkOnly + vbInformation,"Certificate import result"
Else
MSgbox "Fail to install NAPVPN certificate on your Machine" & vbCrLf & "Please contact your local admin!",vbOkOnly + vbCritical,"Certificate import result"
Wscript.Quit 1
End If
objCertStore.close
If Uflag Then
objCertStore.open CAPICOM_CURRENT_USER_STORE, "MY" , CAPICOM_STORE_OPEN_READ_WRITE 'CAPICOM_STORE_OPEN_READ_ONLY
objCertStore.Remove LatestCertificate
objCertStore.close
End If
Set objCertStore = Nothing
Set objCert = Nothing
Set fso = Nothing
End Sub
Sub DeleteUnusedFiles(FileName)
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile FileName
Set objFSO = nothing
End Sub
Function Get_OS(ByRef objWMIService)
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)
For Each objItem in colItems
Get_OS = objItem.Caption
Next
Set colItems = Nothing
End Function
Function Get_OS_TYPE(ByRef objWMIService)
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
For Each objItem in colItems
If instr( objItem.SystemType,"64") <> 0 Then
Get_OS_TYPE = "x64"
Else
Get_OS_TYPE = "x86"
End If
Next
Set colItems = Nothing
End Function
Function Wscript_Engine()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set SystemDirectory = objFSO.GetSpecialFolder(1)
If Instr(UCase(Wscript.FullName),UCase(SystemDirectory)) <> 0 Then
Wscript_Engine = "x86"
Else
Wscript_Engine = "x64"
End If
End Function
Function ElevationCheck 'test whether user has elevated token
Dim oShell, oExecWhoami, oWhoamiOutput, strWhoamiOutput, boolHasElevatedToken
Set oShell = CreateObject("WScript.Shell")
Set oExecWhoami = oShell.Exec("whoami /groups")
Set oWhoamiOutput = oExecWhoami.StdOut
strWhoamiOutput = oWhoamiOutput.ReadAll
If InStr(1, strWhoamiOutput, "S-1-16-12288", vbTextCompare) Then boolHasElevatedToken = True
If boolHasElevatedToken Then
ElevationCheck = True
Else
ElevationCheck = False
End If
End Function
------------------------------------------------------------------------------------------------------------------------------env check
On Error Resume Next
Const HKEY_CLASSES_ROOT = &H80000000
Const CAPICOM_LOCAL_MACHINE_STORE = 1 'The store is a local machine store.
Const CAPICOM_STORE_OPEN_READ_WRITE = 1 'Open the store in read/write mode.
Const CertReq = "certreq.exe"
currentDirectory = left(WScript.ScriptFullName,(Len(WScript.ScriptFullName))-(len(WScript.ScriptName)))
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
OS = Get_OS(objWMIService)
OS_Type = Get_OS_TYPE(objWMIService)
If ( instr(UCase(OS),UCase("Windows 7")) <> 0 ) and (OS_Type="x64")Then
Script_Engine_Arch = Wscript_Engine
If (Script_Engine_Arch = "x86") or (ElevationCheck = False) Then
Set objShell = CreateObject( "WScript.Shell" )
WINDIR=objShell.ExpandEnvironmentStrings("%windir%")
colScriptBase_Engine = Split(Wscript.FullName,"\")
objScriptEngine = colScriptBase_Engine(UBound(colScriptBase_Engine))
x64ScriptEngine = WINDIR & "\SysWOW64\" & objScriptEngine
Set objelevate = CreateObject("Shell.Application")
objelevate.ShellExecute x64ScriptEngine , Chr(34) & Wscript.ScriptFullName & Chr(34) ,"","runas",1
Else
Main
End If
End If
Sub Main
PackageCheck
RegisterCapicom
InstallMainCA
End Sub
Sub InstallMainCA()
On Error Resume Next
set oCertStore = CreateObject ("CAPICOM.Store")
set oCert = CreateObject ("CAPICOM.Certificate")
Certificate = currentDirectory & "certnew.cer"
oCertStore.Open 1, "ROOT", 2
oCert.Load Certificate, , 1, 1
oCertStore.Add oCert
If Err.Number <> 0 Then
Msgbox Err.Description,vbYesonly + vbCritical, "Root Certificate Import Result"
Wscript.Quit 1
Else
Msgbox "Root Certificate has been installed on this computer Successfully.",vbYesonly + vbInformation, "Root Certificate Import Result"
End If
End Sub
Function Get_OS(ByRef objWMIService)
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)
For Each objItem in colItems
Get_OS = objItem.Caption
Next
Set colItems = Nothing
End Function
Function Get_OS_TYPE(ByRef objWMIService)
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
For Each objItem in colItems
If instr( objItem.SystemType,"64") <> 0 Then
Get_OS_TYPE = "x64"
Else
Get_OS_TYPE = "x86"
End If
Next
Set colItems = Nothing
End Function
Function Wscript_Engine()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set SystemDirectory = objFSO.GetSpecialFolder(1)
If Instr(UCase(Wscript.FullName),UCase(SystemDirectory)) <> 0 Then
Wscript_Engine = "x86"
Else
Wscript_Engine = "x64"
End If
End Function
Sub PackageCheck()
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(objFSO.GetSpecialFolder(1) & "\" & Certreq) = False Then
objFSO.CopyFile currentDirectory & CertReq , objFSO.GetSpecialFolder(1) & "\"
End If
If err.number <> 0 Then
Msgbox "Fail to install certreq to system!",vbOkOnly + vbCritical, "Certreq error code"
Wscript.Quit 1
End If
Set objFSO = nothing
End Sub
'''\\Copy and register Capicom.dll from system32 directory if it is missing in client system\\
Sub RegisterCapicom
Dim SystemDirectory, FileSystemObj, ShellObj
WScript.Echo "Check local system for capicom registration...."
If CapicomRegged Then
'WScript.Echo "Capicom was registered before the launch of this script!!"
MsgBox("CAPICOM.DLL was registered!!")
Exit Sub
Else
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set SystemDirectory = objFSO.GetSpecialFolder(1) 'get system32 folder
If objFSO.FileExists( SystemDirectory & "\capicom.dll" ) = False Then
If objFSO.FileExists ( currentDirectory & "capicom.dll" ) = True Then
objFSO.CopyFile currentDirectory & "capicom.dll", SystemDirectory & "\"
'
Else
MsgBox("CAPICOM.DLL is missing! Please ensure CAPICOM.DLL is in the same directory as this program.")
' FileSystemObj.CopyFile currentDirectory & "capicom.dll", SystemDirectory & "\"
End If
Else
Set ShellObj = Wscript.CreateObject("Wscript.Shell")
ShellObj.Run "cmd.exe /c regsvr32.exe /s " & Chr(34) & SystemDirectory & "\capicom.dll" & Chr(34),0,vbTrue
'WScript.Echo "Capicom.dll v2.1.0.3 is now registered in your" & VbCrLf & "System Directory: " & SystemDirectory & VbCrLf & "Please rerun this script..."
MsgBox("Capicom.dll v2.1.0.3 is now registered!")
Set shellobj = Nothing
End If
set objFSO = Nothing
End If
'Wscript.Quit 0
End Sub
'''\\\Check is Capicom regged or not...
Function CapicomRegged()
Dim strComputer, objReg, strKeyPath, RegKeyExists, strValueName, returnValue
strComputer = "."
strKeyPath = "CLSID\"
strValueName = "{03ACC284-B757-4B8F-9951-86E600D2CD06}"
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
objReg.EnumKey HKEY_CLASSES_ROOT, strKeyPath, returnValue
CapicomRegged = False
If Not IsNull(returnValue) Then
'WScript.Echo "Goto For loop"
For Each s In returnValue
'WScript.Echo s
If lcase(s) = lcase(strValueName) Then
CapicomRegged = True
'WScript.Echo RegKeyExists
Exit Function
End If
Next
End If
End Function
Function ElevationCheck 'test whether user has elevated token
Dim oShell, oExecWhoami, oWhoamiOutput, strWhoamiOutput, boolHasElevatedToken
Set oShell = CreateObject("WScript.Shell")
Set oExecWhoami = oShell.Exec("whoami /groups")
Set oWhoamiOutput = oExecWhoami.StdOut
strWhoamiOutput = oWhoamiOutput.ReadAll
If InStr(1, strWhoamiOutput, "S-1-16-12288", vbTextCompare) Then boolHasElevatedToken = True
If boolHasElevatedToken Then
ElevationCheck = True
Else
ElevationCheck = False
End If
End Function
1 則留言:
跨platform須注意Cryptography問題
如AES在windows xp跑的是prototype但在windows 7直接跑AES
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Cryptography\Defaults\provider
張貼留言