'模块说明:读取与替换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



'###################################
'########### class ###################
'###################################

'---------------------------------------------------------------------------------------
' Module : cTabControl32
' DateTime : 2005-3-24 21:16
' Author : Lingll
' Purpose :
'---------------------------------------------------------------------------------------

Option Explicit

Private Declare Function CreateWindowEx Lib "user32.dll" Alias _
"CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal _
lpWindowName
As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal _
hMenu
As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function
DestroyWindow Lib "user32.dll" (ByVal Hwnd As Long) As Long

Private Declare Sub
InitCommonControls Lib "comctl32.dll" ()

Private Const WC_TABCONTROL As String = "SysTabControl32"

Private Type TCITEM
mask
As Long
dwState As Long
dwStateMask As Long
pszText As String
cchTextMax As Long
iImage As Long
lParam As Long
End
Type


Private Const WS_CHILD As Long = &H40000000
Private Const WS_CLIPSIBLINGS As Long = &H4000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_Default As Long = WS_CHILD Or WS_CLIPSIBLINGS Or WS_VISIBLE

'--------------------------------------------------
' style
'--------------------------------------------------
Public Enum ctceTCS
TCS_BOTTOM =
&H2
TCS_BUTTONS = &H100
TCS_FIXEDWIDTH = &H400
TCS_FLATBUTTONS = &H8
TCS_FOCUSNEVER = &H8000
TCS_FOCUSONBUTTONDOWN = &H1000
TCS_FORCEICONLEFT = &H10
TCS_FORCELABELLEFT = &H20

TCS_HOTTRACK = &H40
TCS_MULTILINE = &H200
TCS_MULTISelect = &H4
TCS_OWNERDRAWFIXED = &H2000
TCS_RAGGEDRIGHT = &H800
TCS_RIGHT = &H2
TCS_RIGHTJUSTIFY = &H0
TCS_SCROLLOPPOSITE = &H1
TCS_SINGLELINE = &H0
TCS_TABS = &H0
TCS_TOOLTIPS = &H4000
TCS_VERTICAL = &H80
End Enum

' Private Const TCS_BOTTOM As Long = &H2
' Private Const TCS_BUTTONS As Long = &H100
' Private Const TCS_FIXEDWIDTH As Long = &H400
' Private Const TCS_FLATBUTTONS As Long = &H8
' Private Const TCS_FOCUSNEVER As Long = &H8000
' Private Const TCS_FOCUSONBUTTONDOWN As Long = &H1000
' Private Const TCS_FORCEICONLEFT As Long = &H10
' Private Const TCS_FORCELABELLEFT As Long = &H20
' Private Const TCS_HOTTRACK As Long = &H40
' Private Const TCS_MULTILINE As Long = &H200
' Private Const TCS_MULTISelect As Long = &H4
' Private Const TCS_OWNERDRAWFIXED As Long = &H2000
' Private Const TCS_RAGGEDRIGHT As Long = &H800
' Private Const TCS_RIGHT As Long = &H2
' Private Const TCS_RIGHTJUSTIFY As Long = &H0
' Private Const TCS_SCROLLOPPOSITE As Long = &H1
' Private Const TCS_SINGLELINE As Long = &H0
' Private Const TCS_TABS As Long = &H0
' Private Const TCS_TOOLTIPS As Long = &H4000
' Private Const TCS_VERTICAL As Long = &H80

Private Const TCS_EX_FLATSEPARATORS As Long = &H1
Private Const TCS_EX_REGISTERDrop As Long = &H2
'====================================================


'--------------------------------------------------
' notify message
'--------------------------------------------------
Private Type NMHDR
hwndFrom
As Long
idfrom As Long
code As Long
End
Type

Private Const NM_FIRST As Long = 0
Private Const TCN_FIRST As Long = -550

Private Const NM_CLICK As Long = (NM_FIRST - 2)
Private Const NM_RCLICK As Long = (NM_FIRST - 5)
Private Const NM_RELEASEDCAPTURE As Long = (NM_FIRST - 16)
Private Const TCN_FOCUSCHANGE As Long = (TCN_FIRST - 4)
Private Const TCN_SELCHANGING As Long = (TCN_FIRST - 2)
Private Const TCN_SELCHANGE As Long = (TCN_FIRST - 1)
Private Const TCN_LAST As Long = (-580)
'============================================================


Private Const TCM_FIRST As Long = &H1300
Private Const TCM_InsertITEMA As Long = (TCM_FIRST + 7)
Private Const TCM_InsertITEMW As Long = (TCM_FIRST + 62)
Private Const TCM_GETCURSEL As Long = (TCM_FIRST + 11)
Private Const TCM_DeleteITEM As Long = (TCM_FIRST + 8)
Private Const TCM_DeleteALLITEMS As Long = (TCM_FIRST + 9)
Private Const TCM_ADJUSTRECT As Long = (TCM_FIRST + 40)

Private Const TCIF_TEXT As Long = &H1


Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal Hwnd As Long,
ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Const
WM_SETFONT As Long = &H30

Private Type RECT
Left
As Long
Top As Long
Right As Long
Bottom As Long
End
Type

Private Type POINTAPI
x
As Long
y As Long
End
Type

Private Declare Function SetWindowPos Lib "user32.dll" (ByVal Hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const
SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
Private Const HWND_BOTTOM As Long = 1
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function
MoveWindow Lib "user32.dll" (ByVal Hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function
GetParent Lib "user32.dll" (ByVal Hwnd As Long) As Long
Private Declare Function
ScreenToClient Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpPoint As POINTAPI) As Long


Public Event
Changed(vPos&)

Private m_lMsgWnd As Long ' Toolbar parent window
Private m_lTabWnd As Long ' Toolbar window
'Private mIList As Long 'imagelist

Private Const m_def_fontname$ = "宋体"
Private Const m_def_fontsize$ = 9
Private Const m_def_fontcharset = 134

'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
Static
tNMT As NMHDR
CopyMemory tNMT,
ByVal lParam, Len(tNMT)
Select Case tNMT.code
Case TCN_SELCHANGE
RaiseEvent Changed(GetSelected())
End Select
WindowProc = 0
End Function


Public Function
Create(hParent&, vStyle As ctceTCS, x&, y&, cx&, cy&)

Call InitCommonControls
Call Dest
roy

m_lMsgWnd = CreateWindowEx(
0&, "#32770", vbNullString, WS_Default, x, y, cx, cy, hParent, 0, App.hInstance, ByVal 0&)

vStyle = vStyle
Or WS_Default

m_lTabWnd = CreateWindowEx( _
0&, WC_TABCONTROL, "", _
vStyle,
5, 5, cx - 10, cy - 10, _
m_lMsgWnd,
0&, App.hInstance, ByVal 0&)

Call SubClass_TabCtl(m_lMsgWnd, Me)

Create = m_lTabWnd
End Function

Public Sub
SetFont_Obj(vFont As IFont)
If m_lTabWnd <> 0 Then
SendMessage m_lTabWnd, WM_SETFONT, ByVal vFont.hFont, ByVal MAKELONG(-1, 0)
End If
End Sub

Public Sub
SetFont( _
Optional vFontName$ = m_def_fontname, _
Optional vFontSize& = m_def_fontsize, _
Optional vCharset& = m_def_fontcharset)

Dim tFont As IFont

Set tFont = New StdFont
With tFont
.Size = vFontSize
.Name = vFontName
.Charset = vCharset
End With
Call
SetFont_Obj(tFont)
End Sub

Public Sub
AddItem(vPos&, vCaption$)
Dim TabItemInfo As TCITEM
If m_lTabWnd <> 0 Then
With
TabItemInfo ' 添加选项卡片。
.mask = TCIF_TEXT
.pszText = vCaption
End With

SendMessage m_lTabWnd, TCM_InsertITEMA, vPos, TabItemInfo
End If
End Sub

Public Sub
DelItem(vPos&)
If m_lTabWnd <> 0 Then
SendMessage m_lTabWnd, TCM_DeleteITEM, vPos, ByVal 0&
End If
End Sub

Public Sub
Clear()
If m_lTabWnd <> 0 Then
SendMessage m_lTabWnd, TCM_DeleteALLITEMS, 0&, ByVal 0&
End If
End Sub

Public Function
GetSelected() As Long
If
m_lTabWnd <> 0 Then
GetSelected = SendMessage(m_lTabWnd, TCM_GETCURSEL, 0&, ByVal 0&)
Else
GetSelected = -1
End If
End Function

Public Sub
GetAdjustRect(Optional vLeft&, Optional vTop&, _
Optional vRight&, Optional vBottom&)
Dim tRcAd As RECT
Dim tRcWn As RECT
Dim tPt As POINTAPI, tPt2 As POINTAPI

If m_lTabWnd <> 0 Then
SendMessage m_lTabWnd, TCM_ADJUSTRECT, 0, tRcAd
GetWindowRect m_lTabWnd, tRcWn

tPt.x = tRcWn.Left + tRcAd.Left
tPt.y = tRcWn.Top + tRcAd.Top
Call ScreenToClient(GetParent(m_lMsgWnd), tPt)

' tPt.x = tRcWn.Right + tRcAd.Right
' tPt.y = tRcWn.Bottom + tRcAd.Bottom
' Call ScreenToClient(GetParent(m_lMsgWnd), tPt)

vLeft = tPt.x
vTop = tPt.y
vRight = tPt.x + (tRcWn.Right + tRcAd.Right) - (tRcWn.Left + tRcAd.Left)
vBottom = tPt.y + (tRcWn.Bottom + tRcAd.Bottom) - (tRcWn.Top + tRcAd.Top)
End If
End Sub

Public Sub
GetRect(Optional vLeft&, Optional vTop&, _
Optional vRight&, Optional vBottom&)
Dim tRc As RECT
If m_lTabWnd <> 0 Then
GetWindowRect m_lTabWnd, tRc

vLeft = tRc.Left
vTop = tRc.Top
vRight = tRc.Right
vBottom = tRc.Bottom
End I
f
End Sub

Public Sub
Move(x&, y&, cx&, cy&)
If m_lMsgWnd <> 0 And m_lTabWnd <> 0 Then
MoveWindow m_lMsgWnd, x, y, cx, cy, 1
MoveWindow m_lTabWnd, x, y, cx, cy, 1
End If
End Sub

'置于zorder最下
Public Sub SetToBottom()
If m_lTabWnd <> 0 And m_lMsgWnd <> 0 Then
Call
SetWindowPos(m_lMsgWnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE)
End If
End Sub

Public Sub
Destroy()
If m_lTabWnd <> 0 Then
DestroyWindow m_lTabWnd
m_lTabWnd =
0
End If

If
m_lMsgWnd <> 0 Then
DestroyWindow m_lMsgWnd
UnsubClass_TabCtl m_lMsgWnd
m_lMsgWnd =
0
End If
End Sub

Private Function
MAKELONG(wLow As Long, wHigh As Long) As Long
MAKELONG = wHigh * &H10000 + wLow
End Function

Private Sub
Class_Initialize()
Call Destroy
End Sub

Public Property Get
Hwnd() As Long
Hwnd = m_lTabWnd
End Property



'#####################################
'############# form ####################
'#####################################

Option Explicit

Private WithEvents ttab As cTabControl32
Private Declare Function BringWindowToTop Lib "user32.dll" (ByVal Hwnd As Long) As Long
Private Declare Function
MoveWindow Lib "user32.dll" (ByVal Hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function
ScreenToClient Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private
Type POINTAPI
x
As Long
y As Long
End
Type

Private Sub Command1_Click()
ttab.DelItem
2
End Sub

Private Sub
Form_Load()
Set ttab = New cTabControl32
ttab.Create Me.Hwnd, TCS_HOTTRACK,
0, 0, Me.ScaleWidth / 15, Me.ScaleHeight / 15
ttab.AddItem 0, "Tab1"
ttab.AddItem 1, "Tab2"
ttab.AddItem 2, "Tab3"
ttab.AddItem 3, "页4"
'ttab.SetFont
ttab.SetFont
Command1.ZOrder
End Sub
' TabChanged ' 这个 frmTest 的 Private 方法用于处理 Tab Control 页面改变的操作。

Private Sub Form_Resize()
ttab.Move
0, 0, Me.ScaleWidth / 15, Me.ScaleHeight / 15
Dim x&, y&, cx&, cy&
ttab.GetAdjustRect x, y, cx, cy
MoveWindow Frame1.Hwnd, x, y, cx - x, cy - y,
1
End Sub

Private Sub
ttab_Changed(vPos As Long)
Debug.Print vPos
End Sub



Public Declare Function GetInputState Lib "user32" () As Long

Public Sub
newDoEvents() '这个是比较简单,功能较少
If GetInputState() <> 0 then DoEvents
End Sub

'------------------------
Public Const QS_HOTKEY = &H80
Public Const QS_KEY = &H1
Public Const QS_MOUSEBUTTON = &H4
Public Const QS_MOUSEMOVE = &H2
Public Const QS_PAINT = &H20
Public Const QS_POSTMESSAGE = &H8
Public Const QS_SENDMESSAGE = &H40
Public Const QS_TIMER = &H10
Public Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Public Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Public Const QS_INPUT = (QS_MOUSE Or QS_KEY)
Public Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
Public Declare Function GetQueueStatus Lib "user32" (ByVal qsFlags As Long) As Long

Public Function
cGetInputState() '这个可以按自己的要求定义,接收到什么消息才DoEvents
Dim qsRet As Long
qsRet = GetQueueStatus(QS_HOTKEY Or QS_KEY Or QS_MOUSEBUTTON Or QS_PAINT)
if qsRet<>0 then DoEvents
End Function
'有了上面2个函数就不怕影响循环中的运算效率了
'它可以让你的程序循环速度比使用 DoEvents 更快



Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function
LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function
GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function
CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long

Private Sub
Command1_Click()
On Error Resume Next
Dim
lb As Long, pa As Long
'以 text.dll 为例,设 text.dll 功能跟 user32.dll 完全相同。
lb = LoadLibrary(App.Path & "\text.dll")
'取得 text.dll 中 SetWindowTextA 函数的地址
pa = GetProcAddress(lb, "ExploreMap")
'调用 SetWindowTextA 函数过程
pa = CallWindowProc(pa, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&)
'释放...
FreeLibrary lb
Me.Caption = pa
End Sub




1.模块代码如下:
注意:因为有用到AddressOf OnMenu,函数OnMenu只能放在模块部分。

Public Const MF_POPUP = &H10&
Public Const MF_STRING = &H0&
Public Const MF_DISABLED = &H2&
Public Const MF_SEPARATOR = &H800&
Public Const MF_CHECKED = &H8&
Public Const MF_GRAYED = &H1&
Public Const MF_BYCOMMAND = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Declare Function CreateMenu Lib "user32" () As Long
Public Declare Function
GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function
GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function
GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function
CreatePopupMenu Lib "user32" () As Long
Public Declare Function
AppendMenu1 Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function
SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Public Declare Function
DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function
SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public 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
Public
MenuCount As Long '菜单数量,不包括不能触发的菜单
Public MenuText() As String '菜单文本,ID=wParam的菜单的文本为MenuText(wParam - 1000)
Public OldWinProc As Long

Public Function
OnMenu(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'{响应菜单事件}
Select Case wMsg
Case WM_COMMAND
If wParam > 1000 And wParam <= 1000 + MenuCount Then
MsgBox MenuText(wPara
m -
1000)
End If
End Select
OnMenu = CallWindowProc(OldWinProc, hwnd, wMsg, wParam, lParam)
End Function


2.Form1代码如下:
设计窗体的Negotiation=False,以防止弹出对话框或响应OnMenu后窗体上的菜单消失

Private Sub Form_Load()
Call CreateActiveMenu
End Sub

Sub
CreateActiveMenu()
Dim hMenu As Long, hSubMenu As Long
Dim
hPopMenuTmp As Long
ReDim
MenuText(0)

hMenu = GetMenu(Me.hwnd)
'窗体级菜单句柄
If hMenu = 0 Then
'窗体上没有菜单时,创建菜单。这种情况下需在设计阶段设置窗体的NegotiatMenu=False菜单才能显示出来。
hMenu = CreateMenu()
End If

'添加到0级菜单
hSubMenu = hMenu
FullAllSubMenu hSubMenu

'添加到1级菜单
hSubMenu = GetSubMenu(hSubMenu, GetMenuItemCount(hSubMenu) - 1) '获取最后一个0级菜单的句柄
FullAllSubMenu hSubMenu

'添加到2级菜单
hSubMenu = GetSubMenu(hSubMenu, GetMenuItemCount(hSubMenu) - 1)
FullAllSubMenu hSubMenu

'添加到3级菜单
hSubMenu = GetSubMenu(hSubMenu, GetMenuItemCount(hSubMenu) - 1)
FullAllSubMenu hSubMenu

SetMenu Me.hwnd, hMenu
DrawMenuBar Me.hwnd
Me.Refresh

OldWinProc = SetWindowLong(Me.hwnd, GWL_WNDPROC,
AddressOf OnMenu)
End Sub

Sub
FullAllSubMenu(hFather As Long)
'加入全部子菜单
Dim hPopMenuTmp As Long
Dim
i As Integer
hPopMenuTmp = CreatePopupMenu()
For i = 0 To 4
MenuCount = MenuCount + 1
'保存菜单文本,用于菜单事件触发时识别出被选择的菜单对象
ReDim Preserve MenuText(MenuCount)
MenuText(MenuCount) =
"文件" & MenuCount
'加入子菜单,令其ID>1000,说明其为自动生成的菜单
AppendMenu1 hPopMenuTmp, MF_STRING, 1000 + MenuCount, MenuText(MenuCount)
'如果是间隔线,则wFlags=MF_SEPARATOR
'如果要Check,则wFlags=MF_STRING + MF_CHECKED,若令不可用,则再加MF_GRAYED
Next
AppendMenu1 hFather, MF_POPUP, hPopMenuTmp, "&Files"
End Sub



Option Explicit

Dim AppEXE() As Byte
Dim
FileNum As Long

Private Sub
Test()
'将自定义资源中101号资源读入数组
AppEXE = LoadResData(101, "CUSTOM")
FileNum = FreeFile
'以二进制方式写(生成)temp1.exe到当前目录
Open "C:\Test.exe" For Binary As #FileNum
Put #1, , AppEXE
Close
#FileNum
'运行Test.exe
Shell "C:\Test.exe"
End Sub