'注释
The DeviceIoControl function sends a control code directly to a specified device driver, causing the corresponding device to perform the corresponding operation.

'声明
Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long

'各个参数注解
?hDevice
[in] Handle to the device on which to perform the operation, typically a volume, directory, file, or alternate stream. To retrieve a device handle, use the function.

?dwIoControlCode
[in] Specifies the control code for the operation. This value identifies the specific operation to be performed and the type of device on which to perform it.
For a list of the control codes and a short description of each control code, see Device Input and Output Control Codes .

For more detailed information on each control code, see its documentation. In particular, the documentation provides details on the usage of the lpInBuffer, nInBufferSize, lpOutBuffer, nOutBufferSize, and lpBytesReturned parameters.

?lpInBuffer
[in] Pointer to a buffer that contains the data required to perform the operation.
This parameter can be NULL if the dwIoControlCode parameter specifies an operation that does not require input data.

?nInBufferSize
[in] Specifies the size, in bytes, of the buffer pointed to by lpInBuffer.

?lpOutBuffer
[out] Pointer to a buffer that receives the operation's output data.
This parameter can be NULL if the dwIoControlCode parameter specifies an operation that does not produce output data.

?nOutBufferSize
[in] Specifies the size, in bytes, of the buffer pointed to by lpOutBuffer.

?lpBytesReturned
[out] Pointer to a variable that receives the size, in bytes, of the data stored into the buffer pointed to by lpOutBuffer.
If the output buffer is too small to return any data, then the call fails, returns the error code ERROR_INSUFFICIENT_BUFFER, and the returned byte count is zero.
If the output buffer is too small to hold all of the data but can hold some entries, then the operating system returns as much as fits, the call fails, GetLastError returns the error code ERROR_MORE_DATA, and lpBytesReturned indicates the amount of data returned. Your application should call DeviceIoControl again with the same operation, specifying a new starting point.
If lpOverlapped is NULL, lpBytesReturned cannot be NULL. Even when an operation produces no output data, and lpOutBuffer can be NULL, DeviceIoControl makes use of the variable pointed to by lpBytesReturned. After such an operation, the value of the variable is without meaning.
If lpOverlapped is not NULL, lpBytesReturned can be NULL. If this is an overlapped operation, you can get the number of bytes returned by calling . If hDevice is associated with an I/O completion port, you can get the number of bytes returned by calling .

?lpOverlapped
[in] Pointer to an structure.

If hDevice was opened with the FILE_FLAG_OVERLAPPED flag, lpOverlapped must point to a valid OVERLAPPED structure. In this case, the operation is performed as an overlapped (asynchronous) operation. If the device was opened with FILE_FLAG_OVERLAPPED and lpOverlapped is NULL, the function fails in unpredictable ways.
If hDevice was opened without specifying the FILE_FLAG_OVERLAPPED flag, lpOverlapped is ignored and DeviceIoControl does not return until the operation has been completed, or an error occurs.

'返回值
If the function succeeds, the return value is nonzero.

If the function fails, the return value is zero. To get extended error information, call GetLastError.

'例子
'Example by Howard Henry Schlunder
' This example requires one command button (Command1)
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const INVALID_HANDLE_VALUE = -1
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_Delete_ON_CLOSE = 67108864
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const IOCTL_STORAGE_EJECT_MEDIA = 2967560
Private Const VWIN32_DIOC_DOS_IOCTL = 1

Private Type DIOC_REGISTERS
reg_EBX As Long
reg_EDX As Long
reg_ECX As Long
reg_EAX As Long
reg_EDI As Long
reg_ESI As Long
reg_Flags As Long
End Type

Private Sub Command1_Click()
Dim hDrive As Long, DummyReturnedBytes As Long
Dim EjectDrive As String, DriveLetterAndColon As String
Dim RawStuff As DIOC_REGISTERS
EjectDrive = InputBox("Which drive shall we try to eject the media from?", "Eject Media")
If Len(EjectDrive) Then 'Confirm the user didn't cancel
DriveLetterAndColon = UCase(Left$(EjectDrive & ":", 2)) 'Make it all caps for easy interpretation
If GetVersion >= 0 Then 'We are running Windows NT/2000
hDrive = CreateFile("\\.\" & DriveLetterAndColon, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, OPEN_EXISTING, 0, 0)
If hDrive <> INVALID_HANDLE_VALUE Then
'Eject media!
Call DeviceIoControl(hDrive, IOCTL_STORAGE_EJECT_MEDIA, 0, 0, 0, 0, DummyReturnedBytes, ByVal 0)
Call CloseHandle(hDrive) 'Clean up after ourselves
End If
Else 'We are running Win9x/Me
hDrive = CreateFile("\\.\VWIN32", 0, 0, ByVal 0, 0, FILE_FLAG_Delete_ON_CLOSE, 0)
If hDrive <> INVALID_HANDLE_VALUE Then
'Setup our raw registers to use Interrupt 21h Function 440Dh Minor Code 49h
RawStuff.reg_EAX = &H440D 'The function to use
RawStuff.reg_EBX = Asc(DriveLetterAndColon) - Asc("A") + 1 'The drive to do it on
RawStuff.reg_ECX = &H49 Or &H800 'The minor code of the function in the low byte of the low word and the device category of 8 in the high byte of the low word
'Eject media!
Call DeviceIoControl(hDrive, VWIN32_DIOC_DOS_IOCTL, RawStuff, LenB(RawStuff), RawStuff, LenB(RawStuff), DummyReturnedBytes, ByVal 0)
Call CloseHandle(hDrive) 'Clean up after ourselves
End If
End If
End If
End Sub

'模块说明:读取与替换ini项数据
Option Explicit

Public Type iniFiles
iniValue As String '项值
iniType As String '项名
End Type

Public iniFile() As iniFiles

'函数名称 : ReadINI(iPath,TagType,iniFileValue())
'举 例 : ReadINI(文件路径,标签名,数值())
'作 用 : 读取ini文件指定标签中的所有数据
Public Function ReadINI(iPath As String, TagType As String, iniFileValue() As iniFiles) As Boolean
Dim iFile As Integer, LoadBytes() As Byte
Dim iniTmpFile As String, iniTmp As String '临时存储
Dim iniData() As iniFiles '最后赋值

Dim FstSearch As String, EndSearch As String '开始/最后
Dim FstPos As Long, EndPos As Long '开始/最后
Dim MidPos As Long, NexPos As Long '中间/下一
Dim LenFst As Integer, NowPos As Integer
'从数据文件中读取信息，加入到iniFileValue()中
If Dir(iPath) <> "" Then
'打开文件 开始
iFile = FreeFile
Open iPath For Binary As #iFile
ReDim LoadBytes(1 To LOF(iFile)) As Byte
Get #iFile, , LoadBytes
Close #iFile
iniTmpFile = StrConv(LoadBytes, vbUnicode) '先全部读取 在对字符串进行操作
'打开文件 结束
'[标签0]...[标签1]...[标签2]...[标签3]
FstSearch = UCase("[" & TagType & "]" & vbCrLf) '设置开始 字符
EndSearch = UCase(vbCrLf & "[") '设置结束 字符
LenFst = Len(FstSearch)

ReDim iniData(Len(iniTmpFile)) As iniFiles

FstPos = InStr(UCase(iniTmpFile), FstSearch) '查找 开始字符 StaTag 的位置
EndPos = InStr(FstPos + LenFst, UCase(iniTmpFile), EndSearch) '查找 最后字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmpFile) + 1 '查找 错误 EndPos = 最后位置

If FstPos > 0 And EndPos > FstPos Then
iniTmp = Mid$(iniTmpFile, FstPos + LenFst, EndPos - (FstPos + LenFst)) '获取 区域字符串

FstPos = 1: NowPos = 0
MidPos = InStr(iniTmp, "=") '查找 开始字符 StaTag 的位置

EndPos = InStr(MidPos + 1, iniTmp, vbCrLf) '查找 结束字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmp) + 1 '查找 错误 EndPos = 最后位置

NexPos = InStr(EndPos + 1, iniTmp, "=") '查找 最后字符 EndTag 的位置
If NexPos = 0 Then NexPos = Len(iniTmp) '查找 错误 EndPos = 最后位置

iniData(NowPos).iniType = Trim$(Mid$(iniTmp, FstPos, MidPos - FstPos)) '获取 "Type = Value" 的 Type
iniData(NowPos).iniValue = Trim$(Mid$(iniTmp, MidPos + 1, EndPos - MidPos)) '获取 "Type = Value" 的 Value
'循环查找
While NexPos > 0 And NexPos <> Len(iniTmp)
FstPos = EndPos + Len(vbCrLf): NowPos = NowPos + 1
MidPos = InStr(FstPos, iniTmp, "=") '查找 开始字符 StaTag 的位置

color="#000000">EndPos = InStr(MidPos + 1, iniTmp, vbCrLf) '查找 结束字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmp) + 1 '查找 错误 EndPos = 最后位置

NexPos = InStr(EndPos + 1, iniTmp, "=") '查找 最后字符 EndTag 的位置
If NexPos = 0 Then NexPos = Len(iniTmp) '查找 错误 EndPos = 最后位置

iniData(NowPos).iniType = Trim$(Mid$(iniTmp, FstPos, MidPos - FstPos)) '获取 "Type = Value" 的 Type
iniData(NowPos).iniValue = Trim$(Mid$(iniTmp, MidPos + 1, EndPos - MidPos)) '获取 "Type = Value" 的
Wend
Else
NowPos = 0
iniData(NowPos).iniType = "Null"
iniData(NowPos).iniValue = "Null"
End If

ReDim iniFileValue(NowPos) As iniFiles
For iFile = 0 To NowPos
iniFileValue(iFile) = iniData(iFile)
Next iFile
ReadINI = True
End If
End Function

'函数名称 : ReplaceINI(iPath,TagType,iniFileValue())
'举 例 : ReplaceINI(文件路径,标签名,数值())
'作 用 : 替换ini文件指定标签中的所有数据
Function ReplaceINI(iPath As String, TagType As String, iniFileValue() As iniFiles)
Dim iFile As Integer
Dim FstSearch As String, EndSearch As String '开始/最后
Dim FstPos As Long, EndPos As Long '开始/最后
Dim iniTmp As String, iniTmpFile(1) As String
Dim iniFile As String

If Dir(iPath) <> "" Then
'打开文件 开始
iFile = FreeFile
Open iPath For Binary As #iFile
ReDim LoadBytes(1 To LOF(iFile)) As Byte
Get #iFile, , LoadBytes
Close #iFile
iniTmp = StrConv(LoadBytes, vbUnicode) '先全部读取 在对字符串进行操作
'打开文件 结束
'[标签0]...[标签1]...[标签2]...[标签3]
FstSearch = UCase("[" & TagType & "]" & vbCrLf) '设置开始 字符
EndSearch = UCase(vbCrLf & "[") '设置结束 字符

FstPos = InStr(UCase(iniTmp), FstSearch) '查找 开始字符 StaTag 的位置
If FstPos = 0 Then FstPos = Len(iniTmp) + 1 '查找 错误 StaTag = 最后位置
EndPos = InStr(FstPos + 1, UCase(iniTmp), EndSearch) '查找 最后字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmp) + 1 '查找 错误 EndPos = 最后位置

If FstPos > Len(vbCrLf) Then FstPos = FstPos - Len(vbCrLf) + 1

If EndPos > Len(vbCrLf) Then EndPos = EndPos + Len(vbCrLf)
If FstPos <> 1 Then
iniTmpFile(0) = Mid$(iniTmp, 1, FstPos) '文件头
End If
iniTmpFile(1) = Mid$(iniTmp, EndPos, Len(iniTmp) + 1) '文件尾
Else
iniTmpFile(0) = "": iniTmpFile(1) = ""
End If

iniFile = iniTmpFile(0) '增加文件头
iniFile = iniFile & r="#808080">"[" & TagType & "]" & vbCrLf
For iFile = 0 To UBound(iniFileValue)
iniFile = iniFile & iniFileValue(iFile).iniType & " = " & iniFileValue(iFile).iniValue & vbCrLf
Next iFile

If iniTmpFile(1) <> "" Then
iniFile = iniFile & iniTmpFile(1) '增加文件尾
Else
iniFile = Mid$(iniFile, 1, Len(iniFile) - Len(vbCrLf)) '过滤最后的回车键
End If

iFile = FreeFile
Open iPath For Output As #iFile
Print #iFile, iniFile
Close #iFile
End Function

'窗体部分:
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