'窗体部分:
Private Sub Command1_Click()
Script.AddItem ("坐标：" & MouseX.Text & "-" & MouseY.Text)
End Sub

Private Sub Command2_Click()
Script.AddItem ("鼠标：左键")
End Sub

Private Sub Command3_Click()
Script.AddItem ("鼠标：右键")
End Sub

Private Sub Command4_Click()
If KeyText.Text <> "" Then
Script.AddItem ("键盘：" & KeyText.Text)
End If
End Sub

Private Sub Command5_Click()
'==============================
'功能：保存脚本
'参数：script.txt -> 脚本文件名
'==============================
Dim i As Integer
Open App.Path + "\script.txt" For Output As #1
For i = 1 To Script.ListCount
Print #1, Script.List(i - 1) '这里使用 i-1 是因为 ListBox 控件是从 0 开始
Next i
Close #1
MsgBox "保存完毕！", vbOKOnly, "保存脚本"
End Sub
Private Sub Command6_Click()
End
End Sub

Private Sub Command7_Click()
Call Start
End Sub

Private Sub Form_Load()
'==============================
'功能：读取脚本
'参数：script.txt -> 脚本文件名
'==============================
Dim Scriptemp As String

If Dir(App.Path + "\script.txt") = "" Then
Open App.Path + "\script.txt" For Output As #1
Close #1
End If

Open App.Path + "\script.txt" For Input As #1
While Not EOF(1)
Line Input #1, Scriptemp
Script.AddItem Scriptemp
Wend
Close #1
End Sub

Private Sub KeyText_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case 112
KeyText.Text = "F1"
Case 113
KeyText.Text = "F2"
Case 114
KeyText.Text = "F3"
Case 115
KeyText.Text = "F4"
Case 116
KeyText.Text = "F5"
Case 117
KeyText.Text = "F6"
Case 118
KeyText.Text = "F7"
Case 119
KeyText.Text = "F8"
Case 120
KeyText.Text = "F9"
Case 121
KeyText.Text = "F10"
Case 122
KeyText.Text = "F11"
Case 123
KeyText.Text = "F12"
Case Else
KeyText.Text = Chr(KeyCode)
End Select
End Sub

'处理坐标是否超出一定长度
Private Sub MouseX_Change()
If Len(MouseX.Text) > 4 Then
MsgBox "坐标错误，请重新输入"
MouseX.Text = "0"
End If
End Sub

Private Sub MouseY_Change()
If Len(MouseY.Text) > 4 Then
MsgBox "坐标错误，请重新输入"
MouseY.Text = "0"
End If
End Sub

'模块1:
Option Explicit

Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = font>&H4
Public Const MOUSEEVENTF_RIGHTDOWN = &H8
Public Const MOUSEEVENTF_RIGHTUP = &H10

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long '获得鼠标位置的 API
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long '设置鼠标位置的 API

Public Type POINTAPI
X As Long
Y As Long
End Type

Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) '鼠标事件


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '程序延迟

'模块2
Option Explicit

'=====================
'功能：运行脚本
'=====================
Public Sub Start()
Dim i As Integer
Dim Script1 As String
Dim ScriptLen As Integer
Dim MousePos() As String
Dim MouseCurPos As POINTAPI

If KeyVirtual.Script.ListCount = 0 Then
MsgBox "请添加脚本", vbOKOnly, "错误"
Exit Sub
Else
For i = 0 To KeyVirtual.Script.ListCount - 1 '从 ListBox 的第一个开始
Sleep 1000 '程序延迟 1 秒
Script1 = KeyVirtual.Script.List(i) '获得脚本
ScriptLen = Len(Script1) '获得脚本字符长度
Select Case Mid(Script1, 1, 2) '选择脚本字符前两个字符
Case "坐标"
Script1 = Mid(Script1, 4, ScriptLen - 3) '获得后面的字符
MousePos = Split(Script1, "-") '通过 - 来分割获得坐标，并放到 MousePos（数组）里面
SetCursorPos CLng(MousePos(0)), CLng(MousePos(1)) '设置鼠标位置
Case "鼠标"
GetCursorPos MouseCurPos '获得鼠标坐标到 MousePos（数组）
If Mid(Script1, 4, 2) = "左键" Then
mouse_event MOUSEEVENTF_LEFTDOWN, MouseCurPos.X, MouseCurPos.Y, 0, 0 '设置鼠标左键按下
mouse_event MOUSEEVENTF_LEFTUP, MouseCurPos.X, MouseCurPos.Y, 0, 0 '设置鼠标左键弹出
Else
mouse_event MOUSEEVENTF_RIGHTDOWN, MouseCurPos.X, MouseCurPos.Y, 0, 0 '设置鼠标右键按下
mouse_event MOUSEEVENTF_RIGHTUP, MouseCurPos.X, MouseCurPos.Y, 0, 0 '设置鼠标右键弹出
nt color="#0000FF">End If
Case "键盘"
SendKeys Mid(Script1, 4, ScriptLen - 3) '发送键盘字符
End Select
Next i
End If
End Sub

' ================================================
' 安装程序控件V1.1
' 作者：Huang Guan
' 2005-2-1 14:50
' ================================================

' 获得系统目录路径
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
' 等待指定进程运行结束
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000


Private Function GetSysDir() As String
Dim TmpSysPath As String * 256, TmpLength As Byte
TmpLength = GetSystemDirectory(TmpSysPath, 256)
GetSysDir = Left(TmpSysPath, TmpLength)
End Function
Private Function FileExist(ByVal FilePath As String) As Boolean
If Dir(FilePath, vbNormal Or vbSystem Or vbHidden) <> "" Then
FileExist = True
Else
FileExist = False
End If
End Function
Private Function RunAndWait(ByVal FilePath As String, Optional LongTime As Long = 0) As Boolean
Dim pid As Long
Dim ExitEvent As Long
Dim hProcess As Long '进程句柄
pid = Shell(FilePath, vbNormalNoFocus)
hProcess = OpenProcess(SYNCHRONIZE, False, pid)
If LongTime = 0 Then
ExitEvent = WaitForSingleObject(hProcess, INFINITE)
Else
ExitEvent = WaitForSingleObject(hProcess, LongTime)
End If
RunAndWait = ExitEvent
ExitEvent = CloseHandle(hProcess)
End Function

Public Sub SetupCtrl(ByVal Files As String, ByVal ResID As String)
On Error GoTo ErrHandle
Dim arrCtrls() As String, TempFile() As Byte, arrRes() As String, SystemPath As String, FileNum As Integer
arrCtrls = Split(Files, "|")
arrRes = Split(ResID, "|")
SystemPath = GetSysDir
For i = 0 To UBound(arrCtrls)
If FileExist(SystemPath & "\" & arrCtrls(i)) = False Then
TempFile = LoadResData(arrRes(i), "CUSTOM")
FileNum = FreeFile
Open SystemPath & "\" & arrCtrls(i) For Binary Access Write As #FileNum '新建文件(把 Winsock等 控件复制到指定目录下)
Put #FileNum, , TempFile
Close #FileNum
RunAndWait "regsvr32 " & SystemPath & "\" & arrCtrls(i) & " /s", 0 '注册控件,无弹出对话框
End If
Next
Exit Sub
ErrHandle:
MsgBox Err.Description
End Sub

复杂精确型

' 本模块生成汉字大写的金额
'
Option Explicit
' 名称： CCh
' 得到一位数字 N1 的汉字大写
' 0 返回 ""
Function CCh(N1) As String
Select Case N1
Case 0
CCh = "零"
Case 1
CCh = "壹"
Case 2
CCh = "贰"
Case 3
CCh = "叁"
Case 4
CCh = "肆"
Case 5
CCh = "伍"
Case 6
CCh = "陆"
Case 7
CCh = "柒"
Case 8
CCh = "捌"
Case 9
CCh = "玖"
End Select
End Function '()Function

'名称： ChMoney
' 得到数字 N1 的汉字大写
' 最大为 千万位
' O 返回 ""
Public Function ChMoney(N1) As String
Dim tMoney As String
Dim lMoney As String
Dim tn '小数位置
Dim ST1 As String
Dim T1 As String
Dim s1 As String '临时STRING 小数部分
Dim s2 As String '1000 以内
Dim s3 As String '10000



If N1 = 0 Then
ChMoney = " "
Exit Function
End If
If N1 < 0 Then
ChMoney = "负" + ChMoney(Abs(N1))
Exit Function
End If
tMoney = Trim(Str(N1))
tn = InStr(tMoney, ".") '小数位置
s1 = ""
If tn <> 0 Then
ST1 = Right(tMoney, Len(tMoney) - tn)
If ST1 <> "" Then
T1 = Left(ST1, 1)
ST1 = Right(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s1 = s1 + CCh(Val(T1)) + "角"
End If
If ST1 <> "" Then
T1 = Left(ST1, 1)
s1 = s1 + CCh(Val(T1)) + "分"
End If
End If
ST1 = Left(tMoney, tn - 1)
Else
ST1 = tMoney
End If

s2 = ""
If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
s2 = CCh(Val(T1)) + s2
End If

If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s2 = CCh(Val(T1)) + "拾" + s2
Else
If Left(s2, 1) <> "零" Then s2 = "零" + s2
End If
End If

If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s2 = CCh(Val(T1)) + "佰" + s2
Else
If Left(s2, 1) <> "零" Then s2 = "零" + s2
End If
End If

If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s2 = CCh(Val(T1)) + "仟" + s2
Else
If Left(s2, 1) <> "零" Then s2 = "零" + s2
End If
End If

s3 = ""
If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
s3 = CCh(Val(T1)) + s3
End If


If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s3 = CCh(Val(T1)) + "拾" + s3
Else
If Left(s3, 1) <> "零" Then s3 = "零" + s3
End If
End If

If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s3 = CCh(Val(T1)) + "佰" + s3
Else
If Left(s3, 1) <> "零" Then s3 = "零" + s3
End If
End If

If ST1 <> "" Then
T1 = Right(ST1, 1)
ST1 = Left(ST1, Len(ST1) - 1)
If T1 <> "0" Then
s3 = CCh(Val(T1)) + "仟" + s3
End If
End If
If Right(s2, 1) = "零" Then s2 = Left(s2, Len(s2) - 1)

If Len(s3) > 0 Then

If Right(s3, 1) = "零" Then s3 = Left(s3, Len(s3) - 1)
s3 = s3 & "万"
End If

ChMoney = IIf(s3 & s2 = "", s1, s3 & s2 & "元整" & s1)
End Function

简单明了型

Function RMBChinese(ByVal Rmb As Double) As String
On Error Resume Next
Dim Rmbexp As String, Rmbda As String, Expda As String, Lent As Integer, Ntyp As Integer, Icnt As Integer, i As Integer, Trmb As String

Rmb = Format(Rmb, "###0.00")
If Rmb > 999999999999.99 Then
RMBChinese = "需转换的金额整数长度超过了12位！"
Exit Function
End If

Rmbexp = "分角元拾佰仟万拾佰仟亿拾佰仟"
Rmbda = "零壹贰叁肆伍陆柒捌玖"
Ntyp = 0
Trmb = Replace(CStr(Format(Rmb, "0.00")), ".", "")

If Left(Trmb, 1) = t color="#808080">"-" Then
Trmb = Mid(Trmb, 2)
Ntyp = 1
End If

Expda = ""
Icnt = Len(Trmb)

For i = 1 To Icnt
Expda = Mid(Rmbda, Val(Mid(Trmb, Icnt - i + 1, 1)) + 1, 1) + IIf(Mid(Rmbexp, i, 1) = "元", Mid(Rmbexp, i, 1) + " ", Mid(Rmbexp, i, 1)) + Expda
Next
RMBChinese = IIf(Ntyp = 1, "负" + Expda, Expda)
End Function

没有想到shell32.dll还隐藏着很多实用的功能函数，比如打开文件夹，查找电脑，最小化所有窗体等等，这个shell32.dll既是一个标准的COM，还是一个可以作为普通的DLL进行函数引用。

引用：Ms Shell Con...

Option Explicit
Dim MsShell As New Shell

Private Sub cmdTest_Click(Index As Integer)
On Error GoTo ToExit '打开错误陷阱
'------------------------------------------------
Select Case Index
'------------------------------------------------
Case 0: '查找电脑
MsShell.FindComputer
Case 1: '文件运行
MsShell.FileRun
Case 2: '查找文件夹
MsgBox MsShell.BrowseForFolder(Me.hWnd, "查找文件夹", 0).Title
Case 3: '层叠窗口
MsShell.CascadeWindows
Case 4: '查找文件
MsShell.FindFiles
Case 5: 'Windows帮助
MsShell.Help
Case 6: '窗口最小化
MsShell.MinimizeAll
Case 7: '恢复最小化
MsShell.UndoMinimizeALL
Case 8: '打开文件
MsShell.Open ("c:windows otepad.exe")
Case 9: '设置时间
MsShell.SetTime
Case 10: '关闭计算机
MsShell.ShutdownWindows
Case 11: '水平窗口
MsShell.TileHorizontally
Case 12: '垂直窗口
MsShell.TileVertically
Case 13: '路径名称
MsgBox MsShell.NameSpace("c:windowssystem32").Title
End Select

'------------------------------------------------
Exit Sub
'----------------
ToExit:
MsgBox Err.Description
End Sub

代码分为三部分 1 class 、 1 module 、1 form

'###################################
'######## module #####################
'###################################

'---------------------------------------------------------------------------------------
' Module : mdlSubClassEx2
' DateTime : 2005-3-21 00:28
' Author : Lingll
' Purpose : 子类处理的mdl,
' 利用SetProp,可以非常方便的对多个窗口做子类处理
'---------------------------------------------------------------------------------------

Option Explicit

Private Const GWL_WNDPROC = (-4)


Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long


Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal Hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal Hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal Hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


Private Const PROP_PREVPROC = "WinProc"
Private Const PROP_OBJECT = "Object"

Private Const WM_NOTIFY As Long = &H4E


Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

''return 0:pass the message;other:no pass
'Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'WindowProc = 0
'End Function


Private Function WindowProc(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lPrevProc As Long
Dim oObj As cTabControl32

' Get the previous window procedure
lPrevProc = GetProp(Hwnd, PROP_PREVPROC)
Set oObj = PtrToObj(GetProp(Hwnd, PROP_OBJECT))

If wMsg = WM_NOTIFY Then
If oObj.WindowProc(Hwnd, wMsg, wParam, lParam) = 0 Then
WindowProc = CallWindowProc(lPrevProc, Hwnd, wMsg, wParam, lParam)
End If
Else
WindowProc = CallWindowProc(lPrevProc, Hwnd, wMsg, wParam, lParam)
End If

End Function


Private Function PtrToObj(ByVal lPtr <
/font>As Long) As Object
Dim oUnk As Object

MoveMemory oUnk, lPtr, 4&
Set PtrToObj = oUnk
MoveMemory oUnk, 0&, 4&

End Function


Public Sub SubClass_TabCtl(ByVal Hwnd As Long, ByVal Obj As Object)

' Set the properties
SetProp Hwnd, PROP_OBJECT, ObjPtr(Obj)
SetProp Hwnd, PROP_PREVPROC, GetWindowLong(Hwnd, GWL_WNDPROC)

' Subclass the windows
SetWindowLong Hwnd, GWL_WNDPROC, AddressOf WindowProc

End Sub


Public Sub UnsubClass_TabCtl(ByVal Hwnd As Long)
Dim lProc As Long

' Get the window procedure
lProc = GetProp(Hwnd, PROP_PREVPROC)

' Unsubclass the window
SetWindowLong Hwnd, GWL_WNDPROC, lProc

' Remove the properties
RemoveProp Hwnd, PROP_OBJECT
RemoveProp Hwnd, PROP_PREVPROC

End Sub