vb 解密码程序

另一个锋大程序中的代码

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA"培基局 (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Sub Command2_Click()

Dim hwnd As Long, t As Long, s As String * 100‘声明变量hwnd、t为长整形，s为 100个字符的字符型变量，把句柄保存在hwnd中

hwnd = FindWindow(vbNullString, "HJonny")'寻找名为HJonny的窗体标题，这里就比如你的第一个密码程序。

t = FindWindowEx(hwnd, 0, "ThunderRT6TextBox", vbNullString)'这个是寻找其中的一个文本框，也就是迷得密码框的句柄，保存在t中

SendMessage t, 13, 100, s'sendmassage取t句柄，也就是你的密码框中的文本内容。

MsgBox s'配让d出提示

End Sub

自己写不复制，人品好，希望能帮到你

'图上的控件团瞎,你就照着摆上去,然后再宏友把以下代码拷进去,就OK了

Dim lg As Integer

'加密

Private Sub Command1_Click()

Text2 = ""

Dim a(), b() As String

lg = Len(Text1)

ReDim a(lg), b(lg)

For i = 1 To lg

a(i) = Mid(Text1, i, 1)

b(i) = AscW(a(i)) Xor 4

Text2 = Text2 &ChrW(b(i))

Next

End Sub

'解密

Private Sub Command2_Click()

Text3 = "蔽或槐"

Dim a(), b() As String

lg = Len(Text2)

ReDim a(lg), b(lg)

For i = 1 To lg

a(i) = Mid(Text2, i, 1)

b(i) = AscW(a(i)) Xor 4

Text3 = Text3 &ChrW(b(i))

Next

End Sub

'这是我从网上找到的一段加密解密睁察的代码，很不错，正键应该符合要求。

'文本框的multiline属性是用来设置是否可以接受多行文本，只能在窗体上手工设置。

'文本框的scrollbars属性是用来设置是悉清茄否有垂直和水平滚动条的，也只能在窗体上手工设置。

'keyAscii不清楚是作什么用的。

'两个StrConv函数用的太好了，我没想到能处理的这么简单。

Option Explicit

Dim key() As Byte

Sub initkey() '这里为密匙，建议定义的复杂些，我这里仅仅是个示例

ReDim key(9)

key(0) = 12

key(1) = 43

key(2) = 53

key(3) = 67

key(4) = 78

key(5) = 82

key(6) = 91

key(7) = 245

key(8) = 218

key(9) = 190

End Sub

Function Pass_Encode(ByVal s As String) As String '加密

On Error GoTo myerr

initkey

Dim buff() As Byte

buff = StrConv(s, vbFromUnicode)

Dim i As Long, j As Long

Dim k As Long

k = UBound(key) + 1

For i = 0 To UBound(buff)

j = i Mod k

buff(i) = buff(i) Xor key(j)

Next

Dim mstr As String

mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Dim outstr As String

Dim temps As String

For i = 0 To UBound(buff)

k = buff(i) \ Len(mstr)

j = buff(i) Mod Len(mstr)

temps = Mid(mstr, j + 1, 1) + Mid(mstr, k + 1, 1)

outstr = outstr + temps

Next

Pass_Encode = outstr

Exit Function

myerr:

Pass_Encode = ""

End Function

Function Pass_Decode(ByVal s As String) As String '解密

On Error GoTo myerr

initkey

Dim i As Long, j As Long

Dim k As Long, n As Long

Dim mstr As String

mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Dim outstr As String

Dim temps As String

If Len(s) Mod 2 = 1 Then

Pass_Decode = ""

Exit Function

End If

Dim t1 As String

Dim t2 As String

Dim buff() As Byte

Dim m As Long

m = 0

For i = 1 To Len(s) Step 2

t1 = Mid(s, i, 1)

t2 = Mid(s, i + 1, 1)

j = InStr(1, mstr, t1)

k = InStr(1, mstr, t2)

n = j - 1 + (k - 1) * Len(mstr)

ReDim Preserve buff(m)

buff(m) = n

m = m + 1

Next

k = UBound(key) + 1

For i = 0 To UBound(buff)

j = i Mod k

buff(i) = buff(i) Xor key(j)

Next

Pass_Decode = StrConv(buff, vbUnicode)

Exit Function

myerr:

Pass_Decode = ""

End Function

Private Sub Command1_Click()

Text2.Text = Pass_Encode(Text1.Text)

Text3.Text = Pass_Decode(Text2.Text)

End Sub

---