'secWall 客户端申请解密脚本
'此脚本上传指定的文件到集控服务器用户相关共享文件夹，调用B/S架构申请解密流程处理

Dim strAppTitle			'界面窗口标题
Dim strSharedPath		'文件服务器上的共享路径
Dim strMWUser			'当前登录的加密用户
Dim strHostURL			'WEB主机的URL
Dim strDecryptFile()	'解密文件列表

'全局变量初始化
strAppTitle="secWall 申请解密"	'界面窗口标题

'从注册表中读取配置
'上传文件的共享路径
strSharedPath = RegRead("HKEY_CURRENT_USER", "Software\Mawadata\secWall\Transaction", "PrivateSharedPath")
if strSharedPath = "" then
	msgbox "解密事务配置不正确！没有配置服务器存储文件夹。", vbCritical, strAppTitle
	wscript.quit
end if
'格式化路径，strSharedPath必须以反斜杠结束
if right(strSharedPath, 1) <> "\" then strSharedPath = strSharedPath + "\"
	
'当前登录的加密用户
strMWUser = RegRead("HKEY_LOCAL_MACHINE", "Software\Mawadata\secWall\MWCCSvc", "CurrentUser")
if strMWUser = "" then
	msgbox "加密用户没有登录或者客户端软件版本太旧。", vbCritical, strAppTitle
	wscript.quit
end if

'WEB主机的URL路径
strHostURL = RegRead("HKEY_CURRENT_USER", "Software\Mawadata\secWall\Transaction", "HostURL")
if strHostURL = "" then
	msgbox "解密事务配置不正确！没有配置服务器的URL路径。", vbCritical, strAppTitle
	wscript.quit
end if
'格式化路径，strHostURL必须以正斜杠结束
if right(strHostURL, 1) <> "/" then strHostURL = strHostURL + "/"

'复制文件
'strSourceFile：全路径表示的源文件
'strTargetPath：目标文件夹
Function CopyFile(strSourceFile, strTargetPath)
	'复制文件
	on error resume next
	Dim fso
	Dim strTargetFile
	Dim lngCount

	Set fso = CreateObject("Scripting.FileSystemObject")
	'fso.CopyFile strSourceFile, strTargetFile, True	' 覆盖已存在的文件

	strTargetFile = strTargetPath + fso.GetFileName(strSourceFile)
	For lngCount = 1 To 65535
		fso.CopyFile strSourceFile, strTargetFile, False	' 如果文件已存在，返回失败
		If Err.Number = 0 Then
			'复制成功
			CopyFile = strTargetFile
			Exit For
		ElseIf Err.Number = 58 Then
			'文件已存在，自动改名上传
			strTargetFile = strTargetPath + fso.GetBaseName(strSourceFile) + "(" & lngCount & ")." + fso.GetExtensionName(strSourceFile)
			Err.Clear
		Else
			'失败
			CopyFile = ""
			Exit For
		End If
	Next

	Set fso=nothing
End Function

'取命令行参数，资源管理器中当前选中的文件（全路径）由命令行传入
'复制待解密的文件到文件服务器，并生成配置文件
Set objArgs = WScript. Arguments  
if objArgs.Count = 0 then
	msgbox "没有指定待解密的文件。", vbCritical, strAppTitle
	wscript.quit
end if
Redim strDecryptFile(objArgs.Count)

Function RegRead(strRoot, strPath, strName)
	on error resume next
	set ws=wscript.createobject("wscript.shell") 
	RegRead = ws.regread(strRoot & "\" & strPath & "\" & strName)
End Function

Function RegWrite(strRoot, strPath, strName, strValue)
	on error resume next
	set ws=wscript.createobject("wscript.shell") 
	call ws.regwrite(strRoot & "\" & strPath & "\" & strName, strValue)
	RegWrite = Err.Number
End Function

Function RegDelete(strRoot, strPath, strName)
	on error resume next
	set ws=wscript.createobject("wscript.shell") 
	call ws.regdelete(strRoot & "\" & strPath & "\" & strName)
	RegDelete = Err.Number
End Function

Function GetIP(ComputerName) 
	IP = ""
	Dim objWMIService,colItems,objItem,objAddress
	Set objWMIService = GetObject("winmgmts:\\" & ComputerName & "\root\cimv2")
	Set colItems = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
	For Each objItem in colItems
		For Each objAddress in objItem.IPAddress
			If objAddress <> "" then
				if IP <> "" then IP = IP + " "
					IP = IP & objAddress
				Exit For
			End If  
		Next
		'Exit For
	Next
	GetIP = IP
 End Function

Function GetMAC(ComputerName)
	MAC = "" 
	Dim objWMIService,colItems,objItem,objAddress
	Set objWMIService = GetObject("winmgmts:\\" & ComputerName & "\root\cimv2")
	Set colItems = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
	For Each objItem in colItems
		For Each objAddress in objItem.IPAddress
			If objAddress <> "" then
				if MAC <> "" then MAC = MAC + " "
					MAC= MAC & objItem.MACAddress
				'Exit For
			End If  
		Next
		'Exit For
	Next
	GetMAC = MAC
 End Function

Function GetUserName()
	Set obj = CreateObject("WScript.Network")
	GetUserName = obj.UserName
	Set obj = Nothing
End Function

Function GetComputerName()
	Set obj = CreateObject("WScript.Network")
	GetComputerName = obj.ComputerName
	Set obj = Nothing
End Function

Public Function U8Encode(ByRef szString)
	Dim szChar
	Dim szTemp
	Dim szCode
	Dim szHex
	Dim szBin
	Dim iCount1
	Dim iCount2
	Dim iStrLen1
	Dim iStrLen2
	Dim lResult
	Dim lAscVal
	
	szString = Trim(szString)
	iStrLen1 = Len(szString)
	
	For iCount1 = 1 To iStrLen1
		szChar = Mid(szString, iCount1, 1)
		lAscVal = AscW(szChar)
		If lAscVal >= &H0 And lAscVal <= &HFF Then
			If (lAscVal >= &H30 And lAscVal <= &H39) Or _
				(lAscVal >= &H41 And lAscVal <= &H5A) Or _
				(lAscVal >= &H61 And lAscVal <= &H7A) Then
				szCode = szCode & szChar
			Else
				szCode = szCode & "%" & Hex(AscW(szChar))
			End If
		Else
			szHex = Hex(AscW(szChar))
			iStrLen2 = Len(szHex)
			For iCount2 = 1 To iStrLen2
				szChar = Mid(szHex, iCount2, 1)
				Select Case szChar
					Case "0"
						szBin = szBin & "0000"
					Case "1"
						szBin = szBin & "0001"
					Case "2"
						szBin = szBin & "0010"
					Case "3"
						szBin = szBin & "0011"
					Case "4"
						szBin = szBin & "0100"
					Case "5"
						szBin = szBin & "0101"
					Case "6"
						szBin = szBin & "0110"
					Case "7"
						szBin = szBin & "0111"
					Case "8"
						szBin = szBin & "1000"
					Case "9"
						szBin = szBin & "1001"
					Case "A"
						szBin = szBin & "1010"
					Case "B"
						szBin = szBin & "1011"
					Case "C"
						szBin = szBin & "1100"
					Case "D"
						szBin = szBin & "1101"
					Case "E"
						szBin = szBin & "1110"
					Case "F"
						szBin = szBin & "1111"
					Case Else
				End Select
			Next
			szTemp = "1110" & Left(szBin, 4) & "10" & Mid(szBin, 5, 6) & "10" & Right(szBin, 6)
			For iCount2 = 1 To 24
				If Mid(szTemp, iCount2, 1) = "1" Then
					lResult = lResult + 1 * 2 ^ (24 - iCount2)
				Else
					lResult = lResult + 0 * 2 ^ (24 - iCount2)
				End If
			Next
			szTemp = Hex(lResult)
			szCode = szCode & "%" & Left(szTemp, 2) & "%" & Mid(szTemp, 3, 2) & "%" & Right(szTemp, 2)
		End If           
		szBin = vbNullString
		lResult = 0
	Next
	U8Encode = szCode
End Function

Public Function GB2312Encode(strURL)
'URL编码说明
'以下字符在URL中可以不编码
'1、[0-9a-zA-Z]
'2、特殊字符：$-_.+!*’(),
'     2024/1/11 +号本身安全，但+号同时也是空格的编码结果，在解码时会导致歧义
'以下保留字符可以出现在URL中，但原始的字符必须编码
'3、&/:;=?@
'需要编码的字符
'1、ASCII表中没有对应可显示字符的，例如汉字
'2、不安全字符，包括：#”%<>[]{}|\^`~
'3、不当做保留字符来使用的保留字符，即&/:;=?@
    Dim I
    Dim tempChar
    Dim tempStr
    Const chSafeChar = "$-_.!*'(),"
    
    For I = 1 To Len(strURL)
        tempChar = Asc(Mid(strURL, I, 1))
        If tempChar < 0 Then
            ' 汉字，全部编码
            '
            ' GB2312编码高位A1~F7，低位A1~FE
            'If ((((tempChar And &HFF00) / 256) And &HFF) <= &HF7 And _
            '        (((tempChar And &HFF00) / 256) And &HFF) >= &HA1) And _
            '    ((tempChar And &HFF) <= &HFE And _
            '        (tempChar And &HFF) >= &HA1) Then
            ' GB2312编码的汉字
            '    GB2312Encode = GB2312Encode & Mid(strURL, I, 1)
            'Else
            ' 其他（GBK或GB18030编码）
                tempStr = "%" & Right(CStr(Hex(tempChar)), 2)
                tempStr = "%" & Left(CStr(Hex(tempChar)), Len(CStr(Hex(tempChar))) - 2) & tempStr
                GB2312Encode = GB2312Encode & tempStr
            'End If
        ElseIf (tempChar >= 65 And tempChar <= 90) Or _
                (tempChar >= 97 And tempChar <= 122) Or _
                (tempChar >= &H30 And tempChar <= &H39) Or _
                InStr(chSafeChar, Mid(strURL, I, 1)) > 0 Then
            ' 字母数字和安全符号，不编码
            GB2312Encode = GB2312Encode & Mid(strURL, I, 1)
        Else
            ' 其他半角字符都编码
            GB2312Encode = GB2312Encode & "%" & Hex(tempChar)
        End If
    Next
End Function

' 取命令行参数
strReason = ""
Set oArgs = WScript.Arguments
For Each s In oArgs
	If Left(s, 1) = "/" or Left(s, 1) = "-" Then
		s = Mid(s, 2)
	End If
	s = LCase(s)
	If InStr(1, s, "reason=") = 1 Then
		strReason = Mid(s, 8)
		Exit For
	End If
Next

If strReason = "" Then
	'提示用户输入申请解密的理由
	do
		str=InputBox("请说明申请解密原因：", "secWall 解密申请")
		if IsEmpty(str) or str <> "" then exit do
		msgbox "你必须输入申请解密的原因", vbExclamation, "secWall 解密申请"
	loop
	strReason = str
End If

if strReason = "" then wscript.quit		'用户点了取消

strSourceFile = ""
'上传待解密的文件到文件服务器
For x = 0 to objArgs.Count - 1
	If Left(objArgs(x),1) <> "/" AND Left(objArgs(x),1) <> "-" Then
		strDecryptFile(x) = CopyFile(objArgs(x), strSharedPath)
		if strDecryptFile(x) = "" then
			msgbox "文件不能上传到服务器。" & Err.Description, vbCritical, strAppTitle
			wscript.quit
		end if
		if strSourceFile <> "" then strSourceFile = strSourceFile + "|"
		strSourceFile = strSourceFile + strDecryptFile(x)
	End If
Next

UserName=GetUserName()
ComputerName=GetComputerName()
IP=GetIP(ComputerName)
MAC=GetMAC(ComputerName)

strURL = strHostURL & "transaction/apply.asp?User="
strURL = strURL & UserName & "&Computer=" & ComputerName & "&IP=" & GB2312Encode(IP) & "&MAC=" & GB2312Encode(MAC)
strURL = strURL & "&MWUser=" & GB2312Encode(strMWUser) & "&File=" & GB2312Encode(strSourceFile) & "&Reason=" & GB2312Encode(strReason)

on error resume next		'部分第三方浏览器（如360浏览器）替代了系统的IE组件，可能不能完全支持IE组件的属性
Set ie=WScript.CreateObject("internetexplorer.application")
if ie is nothing then 
	Set wshobj=WScript.CreateObject("WScript.Shell")
	on error goto 0				'关闭错误捕获
	if wshobj is nothing then
		' 无法打开事务处理服务器
		msgbox "当前系统浏览器配置错误，无法打开事务处理服务器。", vbCritical
	else
		wshobj.Run strURL

		Set wshobj=nothing
	end if
else
	'以下属性只为了界面干净美观，并不影响功能，不支持的属性可以忽略
	ie.menubar=0								'不显示IE对象菜单栏
	ie.AddressBar=0								'不显示IE对象地址栏
	ie.ToolBar=0								'不显示IE对象工具栏
	ie.StatusBar=0								'不显示IE对象状态栏
	'ie.FullScreen=1							'全屏化IE对象
	ie.Width=640								'设置IE对象宽度
	ie.Height=480								'设置IE对象高度
	ie.Resizable=0								'设置IE对象大小是否可以被改动
	ie.visible=1								'设置是否可见
	on error goto 0				'关闭错误捕获
	
	ie.navigate strURL							'要打开的网址
	
	'ie.quit
	
	Set ie=nothing
end if
