Private Type CRYPTPROTECT_PROMPTSTRUCT
cbSize As Long
dwPromptFlags As Long
hWndApp As Long
szPrompt As Long
End Type
Private Type DATA_BLOB
cbData As Long
pbData As Long
End Type
Private Declare Function CryptProtectData Lib "crypt32.dll" ( _
ByRef pDataIn As DATA_BLOB, _
ByVal szDataDescr As String, _
ByRef pOptionalEntropy As Any, _
ByRef pvReserved As Any, _
ByRef pPromptStruct As Any, _
ByVal dwFlags As Long, _
ByRef pDataOut As DATA_BLOB) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
hpvDest As Any, _
hpvSource As Any, _
ByVal cbCopy As Long)
'CodePage
Private Const CP_ACP = 0 'ANSI
Private Const CP_MACCP = 2 'Mac
Private Const CP_OEMCP = 1 'OEM
Private Const CP_UTF7 = 65000
Private Const CP_UTF8 = 65001
'dwFlags
Private Const WC_NO_BEST_FIT_CHARS = &H400
Private Const WC_COMPOSITECHECK = &H200
Private Const WC_DISCARDNS = &H10
Private Const WC_SEPCHARS = &H20 'Default
Private Const WC_DEFAULTCHAR = &H40
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
'
'*******************************************
Public Function CryptRDPPassword(ByVal spPassword As String) As String
Dim aDataIn() As Byte
Dim udtDataIn As DATA_BLOB
Dim r As Long
Dim udtDataOut As DATA_BLOB
Dim aDataOut() As Byte
Dim s$, i&
Dim szDataDesc As String
Dim strTMP As String
Const CRYPTPROTECT_UI_FORBIDDEN = 1
'the code below DID NOT WORK as byte length was twice as big on Win7 64 bit!
'aDataIn = StrConv(spPassword, vbUnicode)
aDataIn = StringToByteArray(spPassword)
With udtDataIn
.cbData = (UBound(aDataIn) + 1)
.pbData = VarPtr(aDataIn(0))
End With
szDataDesc = StrConv("psw", vbUnicode)
r = CryptProtectData( _
udtDataIn, _
szDataDesc, _
ByVal vbNullString, _
ByVal vbNullString, _
ByVal vbNullString, _
CRYPTPROTECT_UI_FORBIDDEN, _
udtDataOut)
If r Then
ReDim Preserve aDataOut(udtDataOut.cbData)
CopyMemory aDataOut(0), ByVal udtDataOut.pbData, udtDataOut.cbData
s = ""
For i = 0 To udtDataOut.cbData - 1
'the code below DID NOT WORK since Hex(122) should = "7A" and formatted returned "00"
's = s & Format(Hex(aDataOut(i)),"00")
strTMP = Hex(aDataOut(i))
If Len(strTMP) = 1 Then strTMP = "0" & strTMP
s = s & strTMP
Next
CryptRDPPassword = s
Else
CryptRDPPassword = "Nothing"
End If
End Function
'Helper function instead of using StConv
'
Private Function StringToByteArray(strInput As String, _
Optional bReturnAsUnicode As Boolean = True, _
Optional bAddNullTerminator As Boolean = False) As Byte()
Dim lRet As Long
Dim bytBuffer() As Byte
Dim lLenB As Long
If bReturnAsUnicode Then
'Number of bytes
lLenB = LenB(strInput)
'Resize buffer, do we want terminating null?
If bAddNullTerminator Then
ReDim bytBuffer(lLenB)
Else
ReDim bytBuffer(lLenB - 1)
End If
'Copy characters from string to byte array
CopyMemory bytBuffer(0), ByVal StrPtr(strInput), lLenB
Else
'Num of characters
lLenB = Len(strInput)
If bAddNullTerminator Then
ReDim bytBuffer(lLenB)
Else
ReDim bytBuffer(lLenB - 1)
End If
lRet = WideCharToMultiByte(CP_ACP, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(bytBuffer(0)), lLenB, 0&, 0&)
End If
StringToByteArray = bytBuffer
End Function
'sample
Sub main()
End Sub
Private Sub Form_Load()
Dim retSTR As String
retSTR = CryptRDPPassword("sr123456.")
Text1.Text = retSTR
'output from my machine ...
'01000000D08C9DDF0115D1118C7A00C04FC297EB010000009CF58531D06E9F49A61BD864ED7090B90000000008000000700073007700000003660000C000000010000000B873812AF748EBFEB771062DDC11C1070000000004800000A000000010000000E37108E248EF890516A1B3987D3136C218000000CC1666DD310330B3E1B2E77F6956FF3A93E94C5F493CC13E140000005360605D9F45077E3D99D86643C2149A33082C1C
End Sub
已经解决!封帖!