实现毫秒精度的延时
'Module Code:
Option Explicit
Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Declare Function QueryPerformanceCounter Lib "kernel32" _
(lpPerformanceCount As LARGE_INTEGER) As Long
Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
'实现毫秒量级精确延时,(n 毫秒)
Public Sub Wait(ByVal n As Long)
Dim PFrequency As LARGE_INTEGER
Dim Interval As LARGE_INTEGER
Dim Privious As LARGE_INTEGER
Dim Current As LARGE_INTEGER
'获得高精度计数器的频率
QueryPerformanceFrequency PFrequency
'获得高精度运行计数器的值
QueryPerformanceCounter Privious
Current = Privious
Interval.LowPart = (PFrequency.LowPart / 1000) * n
'下面这句可以精确到微秒,好像不太实用,也未必精确到如此地步
'Interval.LowPart = (PFrequency.LowPart / 1000000) * n
Interval.HighPart = 0
'通过比较两次计数器的值差实现高精度延时
Do While (Abs(Current.HighPart * 2 ^ 16) + Current.LowPart) - _
(Abs(Privious.HighPart * 2 ^ 16) + Privious.LowPart) < _
(Abs(Interval.HighPart * 2 ^ 16) + Interval.LowPart)
QueryPerformanceCounter Current
'此句若省略,循环期间其它事就都不能做了
DoEvents
Loop
End Sub
'Form Code:
Option Explicit
Dim l As Long
Private Sub Command1_Click()
l = 0
'对照时钟计时(它并不很精确,这里仅对照而已)
'间隔10毫秒已经很小了
Timer1.Interval = 10
'延时
Wait 5000
'停止计时
Timer1.Interval = 0
MsgBox "你够狠,憋了我5000毫秒才放出来"
End Sub
Private Sub Form_Load()
'共三个控件:一个时钟,一个标签,一个按钮
Command1.Caption = "等待5000毫秒"
Label1.AutoSize = True
Label1.Caption = "这里是时钟计时"
End Sub
Private Sub Timer1_Timer()
l = l + 10
Label1.Caption = l
End Sub
-------------------------------------------------------
VB未公开的三个函数ObjPtr,StrPtr,VarPtr
'Form Code:
'ObjPtr: 返回对象实例私有域的地址
'StrPtr: 返回字符串第一个字的地址
'VarPtr: 返回变量的地址
'使用对象浏览器（Object Browser），你可以发现更多其他对象未公开的细节。
'使用诸如金山游侠之类的游戏修改器可以跟踪到这个变量的地址(查99887766数值)
'需生成EXE,这样容易操作,不会受到VB6干扰
Dim l As Long
Private Sub Command1_Click()
Print "对象实例私有域:", ObjPtr(Command1)
Dim str As String
str = "字符串第一个字的地址:"
Print str, StrPtr(str)
Print "----------------------------------"
Dim ramid As Double
ramid = VarPtr(l)
l = 99887766
Print "变量的内存地址:", VarPtr(l)
Print "转换成十六进制:", Hex(ramid)
Print "变量 l 的值:", l
End Sub
Private Sub Form_Load()
'为了能持久显示,便于查看
Me.AutoRedraw = True
End Sub
'VarPtr用在包含字符串的变量时,可能返回的指针是临时地址(UNICODE转换的缘故)
'StrPtr还是唯一能直观地告诉你空字符串和null字符串的不同的方法。
'对于null字符串(vbNullString)，StrPtr的返回值为0，而对于空字符串，函数的返回值为非零
'详细信息请查阅相关文档
------------------------------------------------------------
'返回阿拉伯数字的中文大写或者普通写法的一个函数
Public Function ChnNumber(Number As Double, _
Optional Capital As Boolean = False, _
Optional Simple As Boolean = False) As String
'返回阿拉伯数字的中文大写或者普通写法
'调用方法例如:Debug.Print ChnNumber(12300.43) '返回:壹萬贰仟叁佰点肆叁
' Debug.Print ChnNumber(12300.43, 1) '返回:一万二千三百点四三
' Debug.Print ChnNumber(12300.43, , 1) '返回:一二三○○点四三
'作者:csdngoodnight
'E-mail:kxufeng@163.com
'Number:阿拉伯数字(12300.43)
'Capital:True为中文大写(壹萬贰仟叁佰点肆叁),默认为False普通(一万二千三百点四三)
'Simple:True为简单排列(壹贰叁零零点肆叁/一二三○○点四三)
If Abs(Number) > CDbl(9.99999999999999E+15) Then
'9999兆9999万9990 or 9999999999999990 or 9.99999999999999E+15
MsgBox "超出这个范围的数字,将会有四舍五入进位情况。" & Space(5) & vbCrLf & _
"难道你...要计算星星的数量?偶帮不了你啦 :(", vbInformation, "老兄:天文数字啊"
'Exit Function
End If
Dim varNumber As Variant
Dim ChnString(1) As String, strClass(1) As String
Dim iNumberLen As Integer, iCapital As Integer
Dim boolZero As Boolean
Dim strTemp As String
Dim i As Integer, j As Integer
strClass(0) = "十百千万亿兆"
strClass(1) = "拾佰仟萬億兆"
ChnString(0) = "○一二三四五六七八九"
ChnString(1) = "零壹贰叁肆伍陆柒捌玖"
varNumber = Split(Format(Number, "0.################"), ".")
iNumberLen = Len(varNumber(0))
If Number < 0 Then
varNumber(0) = Right$((varNumber(0)), iNumberLen - 1)
iNumberLen = iNumberLen - 1
End If
iCapital = Abs(CInt(Capital))
If Simple Then
For i = 1 To iNumberLen
j = CInt(Mid$(varNumber(0), i, 1))
ChnNumber = ChnNumber & Mid$(ChnString(iCapital), j + 1, 1)
Next
If UBound(varNumber) > 0 Then
iNumberLen = Len(varNumber(1))
For i = 1 To iNumberLen
j = CInt(Mid$(varNumber(1), i, 1))
strTemp = strTemp & Mid$(ChnString(iCapital), j + 1, 1)
Next
End If
If Len(strTemp) > 0 Then ChnNumber = ChnNumber & "点" & strTemp
If Number < 0 Then ChnNumber = "[负]" & ChnNumber
Exit Function
End If
If iNumberLen < 2 Then
If iNumberLen = 0 Then varNumber(0) = "0"
ChnNumber = Mid$(ChnString(iCapital), CInt(varNumber(0)) + 1, 1)
Else
For i = 0 To iNumberLen - 1
j = CInt(Mid$(varNumber(0), iNumberLen - i, 1))
strTemp = Mid$(ChnString(iCapital), j + 1, 1)
If j = 0 Then
If boolZero = True Then strTemp = ""
If i Mod 4 = 0 Then
strTemp = ""
boolZero = True
If i > 0 Then
strTemp = Mid$(strClass(iCapital), i / 4 + 3, 1)
If iNumberLen - i > 4 Then
If CInt(Right$(Left$(varNumber(0), iNumberLen - i), 4)) = 0 Then strTemp = ""
End If
End If
End If
If strTemp = "零" And Capital Then boolZero = True
If strTemp = "○" And Not Capital Then boolZero = True
Else
boolZero = False
If i Mod 4 = 0 Then '万亿兆
j = i / 4 Mod 3
If j = 0 Then j = 6 Else j = j + 3 '可能出现的天文数字
If i > 0 Then strTemp = strTemp & Mid$(strClass(iCapital), j, 1)
Else '十百千位
strTemp = strTemp & Mid$(strClass(iCapital), i Mod 4, 1)
End If
End If
ChnNumber = strTemp & ChnNumber
strTemp = ""
Next
End If
'处理小数部分
If UBound(varNumber) > 0 Then
iNumberLen = Len(varNumber(1))
For i = 1 To iNumberLen
j = CInt(Mid$(varNumber(1), i, 1))
strTemp = strTemp & Mid$(ChnString(iCapital), j + 1, 1)
Next
End If
If Len(strTemp) > 0 Then ChnNumber = ChnNumber & "点" & strTemp
If Number < 0 Then ChnNumber = "[负数]" & ChnNumber
End Function
系统托盘图标 例2
将下列文件恢复后:form1.picture1中载入一个图标,运行
【Project Code:将下面代码用记事本保存为 工程1.vbp(VB工程文件),此括弧及括弧内容除外】
Type=Exe
Class=CTray; CTray.cls
Reference=*/G{00020430-0000-0000-C000-000000000046}#2.0#0#C:/WINDOWS/system32/stdole2.tlb#OLE Automation
Form=Form1.frm
Startup="Form1"
HelpFile=""
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="xufeng"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1
Caption = "本例演示托盘图标"
ClientHeight = 3090
ClientLeft = 165
ClientTop = 855
ClientWidth = 4680
Icon = "Form1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 3090
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.PictureBox Picture1
Height = 735
Left = 720
Picture = "Form1.frx":000C
ScaleHeight = 675
ScaleWidth = 915
TabIndex = 0
Top = 600
Width = 975
End
Begin VB.Menu tempmenu
Caption = "托盘菜单"
Begin VB.Menu m_open
Caption = "打开 "
Shortcut = ^O
End
Begin VB.Menu m_save
Caption = "保存"
Shortcut = ^S
End
Begin VB.Menu m_11
Caption = "-"
End
Begin VB.Menu m_exit
Caption = "关闭"
Shortcut = ^Q
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim WithEvents Tray As CTray
Attribute Tray.VB_VarHelpID = -1
Private Sub Form_Load()
'托盘图标
Set Tray = New CTray
With Tray
.TipText = Me.Caption '提示文本
.PicBox = Picture1 '一个用于托盘的图标(PictureBox)
End With
Tray.ShowIcon '添加图标在托盘
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'删除托盘图标
Tray.DeleteIcon
Set Tray = Nothing
End Sub
Private Sub m_exit_Click()
Unload Me
End Sub
'以下为托盘图标事件
Private Sub Tray_LButtonDblClick()
'左键双击
End Sub
Private Sub Tray_LButtonDown()
'左键按下
End Sub
Private Sub Tray_LButtonUp()
'左键放开
End Sub
Private Sub Tray_RButtonDblClick()
'右键双击
End Sub
Private Sub Tray_RButtonDown()
'右键按下
End Sub
Private Sub Tray_RButtonUp()
'右键放开
PopupMenu tempmenu
End Sub
【Class Code:将下面代码用记事本保存为 CTray.cls(类模块文件),此括弧及括弧内容除外】
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "CTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'-------------------------------------------------------------------
'类模块:托盘图标的添加
'-------------------------------------------------------------------
Option Explicit
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pNid As NOTIFYICONDATA) As Boolean
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Type NOTIFYICONDATA
lSize As Long
hWnd As Long
lId As Long
lFlags As Long
lCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private mNID As NOTIFYICONDATA
Private WithEvents mPic As PictureBox
Attribute mPic.VB_VarHelpID = -1
Public Event RButtonDown() '鼠标右键按下
Public Event RButtonUp() '鼠标右键放开
Public Event RButtonDblClick() '鼠标右键双击
Public Event LButtonDown() '鼠标左键按下
Public Event LButtonUp() '鼠标左键放开
Public Event LButtonDblClick() '鼠标左键双击
Private Sub Class_Initialize()
With mNID
.lSize = Len(mNID)
.lCallBackMessage = WM_MOUSEMOVE
.lFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.lId = 1&
End With
End Sub
Private Sub Class_Terminate()
DeleteIcon
Set mPic = Nothing
End Sub
Public Property Let PicBox(ByVal PicBox As PictureBox)
Set mPic = PicBox
With mNID
.hWnd = mPic.hWnd
.hIcon = mPic
End With
End Property
Public Property Get TipText() As String
TipText = mNID.szTip
End Property
Public Property Let TipText(ByVal TipText As String)
mNID.szTip = TipText & Chr$(0)
Shell_NotifyIcon NIM_MODIFY, mNID
End Property
Public Function ShowIcon() As Boolean
If mPic Is Nothing Then
ShowIcon = False
Else
Shell_NotifyIcon NIM_ADD, mNID
ShowIcon = True
End If
End Function
Public Sub DeleteIcon()
Shell_NotifyIcon NIM_DELETE, mNID
End Sub
Private Sub mPic_Change()
mNID.hIcon = mPic
Shell_NotifyIcon NIM_MODIFY, mNID
End Sub
Private Sub mPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static bRec As Boolean
Dim lMsg As Long
lMsg = X / Screen.TwipsPerPixelX
If bRec = False Then
bRec = True
Select Case lMsg
Case WM_LBUTTONDBLCLK:
'左键双击
RaiseEvent LButtonDblClick
Case WM_LBUTTONDOWN:
'左键按下
RaiseEvent LButtonDown
Case WM_LBUTTONUP:
'左键放开
RaiseEvent LButtonUp
Case WM_RBUTTONDBLCLK:
'右键双击
RaiseEvent RButtonDblClick
Case WM_RBUTTONDOWN:
'右键按下
RaiseEvent RButtonDown
Case WM_RBUTTONUP:
'右键放开
RaiseEvent RButtonUp
End Select
bRec = False
End If
End Sub
Shell 函数的几个示例
'Form Code:
'执行一个可执行文件，返回一个 Variant (Double)，
'如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。
'语法
'Shell(pathname[,windowstyle])
'Shell 函数的语法含有下面这些命名参数:
'部分 描述
'pathname 必要参数。Variant (String)，要执行的程序名，以及任何必需的参数或命令行变量， _
可能还包括目录或文件夹，以及驱动器。
'Windowstyle 可选参数。Variant (Integer)，表示在程序运行时窗口的样式。 _
如果 windowstyle 省略，则程序是以具有焦点的最小化窗口来执行的。
'windowstyle 命名参数有以下这些值:
'常数 值 描述
'vbHide 0 窗口是隐藏的，并且焦点被传递给隐藏窗口。
'vbNormalFocus 1 窗口拥有焦点，并且恢复到原来的大小与位置。
'vbMinimizedFocus 2 窗口缩小为图符并拥有焦点。
'vbMaximizedFocus 3 窗口最大化并拥有焦点。
'vbNormalNoFocus 4 窗口被恢复到最近一次的大小与位置。当前活动窗口仍为活动窗口。
'vbMinimizeNoFocus 6 窗口缩小为图符。当前活动窗口仍为活动窗口。
Private Sub Command1_Click()
'如果指定文件夹不存在,则创建
If Dir("c:/mydos", vbDirectory) = "" Then MkDir "c:/mydos" '在硬盘上新建一个c:/mydos的文件夹。
'调用指令,复制一批文件到该文件夹下(需具备xcopy.exe)
Shell "xcopy.exe C:/WINDOWS/Web/Wallpaper/*.* c:/mydos/s/e", vbHide
'使用浏览器打开该目录
Shell "explorer.exe " & "c:/mydos", vbNormalFocus
End Sub
Private Sub Command2_Click()
'把DOS应用程序的屏幕输出写到一个文件中去。
'例如用下列代码可把DOS命令copy的帮助信息写到一个文件中去。
Open "c:/test.bat" For Output As #1 '建立批处理文件
Print #1, "copy/?>c:/copyhelp.txt"
Print #1, "@exit"
Close #1
'执行这个批处理文件
Shell "c:/test.bat", vbHide
'最后一句必须是@exit，不然经Shell调用后的批处理文件无法从内存中退出
End Sub
---------------------------------------
托盘图标 例1
将下列文件恢复后:form1.icon中载入一个图标,运行
【Project Code:将下面代码用记事本保存为 PROJECT1.vbp(VB工程文件),此括弧及括弧内容除外】
Type=Exe
Form=Form1.frm
Reference=*/G{00020430-0000-0000-C000-000000000046}#2.0#0#C:/WINDOWS/system32/stdole2.tlb#OLE Automation
Module=APIStuff; Apistuff.bas
IconForm="Form1"
Startup="Form1"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Rocky Mountain Computer Consulting, Inc."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 4710
ClientLeft = 1635
ClientTop = 1830
ClientWidth = 7665
Icon = "Form1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4710
ScaleWidth = 7665
ShowInTaskbar = 0 'False
Begin VB.Menu mnuFile
Caption = "文件"
Begin VB.Menu mnuFileExit
Caption = "退出"
End
End
Begin VB.Menu mnuTray
Caption = "Popup"
Visible = 0 'False
Begin VB.Menu mnuTrayRestore
Caption = "恢复"
End
Begin VB.Menu mnuTrayMove
Caption = "移动"
End
Begin VB.Menu mnuTraySize
Caption = "大小"
End
Begin VB.Menu mnuTrayMinimize
Caption = "最小化"
End
Begin VB.Menu mnuTrayMaximize
Caption = "最大化"
End
Begin VB.Menu mnuTraySep
Caption = "-"
End
Begin VB.Menu mnuTrayClose
Caption = "关闭"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public LastState As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&
Private Sub Form_Load()
If WindowState = vbMinimized Then
LastState = vbNormal
Else
LastState = WindowState
End If
AddToTray Me, mnuTray
SetTrayTip "VB Helper tray icon program"
End Sub
Private Sub Form_Resize()
Select Case WindowState
Case vbMinimized
mnuTrayMaximize.Enabled = True
mnuTrayMinimize.Enabled = False
mnuTrayMove.Enabled = False
mnuTrayRestore.Enabled = True
mnuTraySize.Enabled = False
Case vbMaximized
mnuTrayMaximize.Enabled = False
mnuTrayMinimize.Enabled = True
mnuTrayMove.Enabled = False
mnuTrayRestore.Enabled = True
mnuTraySize.Enabled = False
Case vbNormal
mnuTrayMaximize.Enabled = True
mnuTrayMinimize.Enabled = True
mnuTrayMove.Enabled = True
mnuTrayRestore.Enabled = False
mnuTraySize.Enabled = True
End Select
If WindowState <> vbMinimized Then _
LastState = WindowState
End Sub
Private Sub Form_Unload(Cancel As Integer)
RemoveFromTray
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuTrayClose_Click()
Unload Me
End Sub
Private Sub mnuTrayMaximize_Click()
WindowState = vbMaximized
End Sub
Private Sub mnuTrayMinimize_Click()
WindowState = vbMinimized
End Sub
Private Sub mnuTrayMove_Click()
SendMessage hwnd, WM_SYSCOMMAND, SC_MOVE, 0&
End Sub
Private Sub mnuTrayRestore_Click()
SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, 0&
End Sub
Private Sub mnuTraySize_Click()
SendMessage hwnd, WM_SYSCOMMAND, SC_SIZE, 0&
End Sub
(待续)
(续)
【Module Code:将下面代码用记事本保存为 *.bas(基本模块文件),此括弧及括弧内容除外】
Attribute VB_Name = "APIStuff"
Option Explicit
Public OldWindowProc As Long
Public TheForm As Form
Public TheMenu As Menu
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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private TheData As NOTIFYICONDATA
Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = TRAY_CALLBACK Then
If lParam = WM_LBUTTONUP Then
If TheForm.WindowState = vbMinimized Then _
TheForm.WindowState = TheForm.LastState
TheForm.SetFocus
Exit Function
End If
If lParam = WM_RBUTTONUP Then
TheForm.PopupMenu TheMenu
Exit Function
End If
End If
NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)
End Function
Public Sub AddToTray(frm As Form, mnu As Menu)
Set TheForm = frm
Set TheMenu = mnu
OldWindowProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
With TheData
.uID = 0
.hwnd = frm.hwnd
.cbSize = Len(TheData)
.hIcon = frm.Icon.Handle
.uFlags = NIF_ICON
.uCallbackMessage = TRAY_CALLBACK
.uFlags = .uFlags Or NIF_MESSAGE
.cbSize = Len(TheData)
End With
Shell_NotifyIcon NIM_ADD, TheData
End Sub
Public Sub RemoveFromTray()
With TheData
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData
SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProc
End Sub
Public Sub SetTrayTip(tip As String)
With TheData
.szTip = tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
Public Sub SetTrayIcon(pic As Picture)
If pic.Type <> vbPicTypeIcon Then Exit Sub
With TheData
.hIcon = pic.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
---------------------------------------------------
几个小函数
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function LenBB(Expression As String) As Integer
'取得字符串实际字节长度
LenBB = LenB(StrConv(Expression, vbFromUnicode))
End Function
'-------------------------------------
'获得我的文档路径
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pIdl As Long, ByVal pszPath As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long
Type SHITEMID
cb As Long
abID() As Byte
End Type
Type ITEMIDLIST
mkid As SHITEMID
End Type
Public Function MyDocumentsDir(oForm As Form) As String
Dim IDL As ITEMIDLIST
Dim sPath As String * 260
If SHGetSpecialFolderLocation(oForm.hWnd, 5, IDL) = 0 Then
If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then
'返回我的文档路径
MyDocumentsDir = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
End If
End Function
'----------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function RangeDiff(RangeNameA As String, RangeNameB As String) As Integer
'返回两列间隔数(Excel表中的列)
Dim a As Integer, b As Integer
If Len(RangeNameA) = 0 Or Len(RangeNameB) = 0 Then Exit Function
RangeNameA = UCase(RangeNameA)
RangeNameB = UCase(RangeNameB)
If Len(RangeNameA) = 1 Then
a = Asc(RangeNameA) - 64
Else
a = (Asc(Left(RangeNameA, 1)) - 64) * 26 + Asc(Right(RangeNameA, 1)) - 64
End If
If Len(RangeNameB) = 1 Then
b = Asc(RangeNameB) - 64
Else
b = (Asc(Left(RangeNameB, 1)) - 64) * 26 + Asc(Right(RangeNameB, 1)) - 64
End If
RangeDiff = b - a
End Function
'-----------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function FindRepeat(strChr As String) As String
'判断字符串是否有重复字符
Dim i As Integer, j As Integer
For i = 1 To Len(strChr)
For j = 1 To Len(strChr)
If j <> i Then
If Mid(strChr, i, 1) = Mid(strChr, j, 1) Then
FindRepeat = Mid(strChr, i, 1)
Exit Function
End If
End If
Next
Next
End Function
'---------------------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
'配合上面那个LenBB函数使用
Public Function FileNameIs(AllFileDir As String, FileDirIs As String) As String
'获取文件路径中的 路径部分 和 文件名部分
'调用:
'Dim filedir As String
'Debug.Print "文件名:", FileNameIs("c:/abc.txt", filedir)
'Debug.Print "路径:", filedir
If Len(AllFileDir) = 0 Then FileDirIs = "": Exit Function
Dim v As Variant
Dim i As Integer
v = Split(AllFileDir, "/")
i = UBound(v)
'取得路径
FileDirIs = Left(AllFileDir, LenBB(AllFileDir) - LenBB(CStr(v(i))) - 1)
'取得文件名
FileNameIs = v(i)
End Function
'---------------------------------------------------
检查窗口是否激活
Public OldWindowProc As Long
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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Const GWL_WNDPROC = (-4)
Const WM_ACTIVATE = &H6
Const WA_ACTIVE = 1
Const WA_CLICKACTIVE = 2
Const WA_INACTIVE = 0
Public Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_ACTIVATE Then
If (wParam = WA_ACTIVE Or wParam = WA_CLICKACTIVE) Then
'活动
debug.print "活动"
Else
'非活动
debug.print "不活动"
End If
End If
NewWindowProc = CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam)
End Function
'窗体load中加上此代码:
OldWindowProc = SetWindowLong(hWnd, (-4), AddressOf NewWindowProc)
-----------------------------------------------------
用API指定文件夹(对话框)
'Module Code:
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
BrowseForFolder = sPath
End Function
'Form Code:
Private Sub Command1_Click()
Dim sDirectoryName As String
sDirectoryName = BrowseForFolder(Me.hWnd, "请选择目录")
Debug.Print sDirectoryName
End Sub
------------------------------------------------
判定Variant变量值的类型
VarType 常数
语法: VarType(varname)
可在代码中的任何地方用下列常数代替实际值：
常数 值 描述
vbEmpty 0 未初始化（缺省值）
vbNull 1 不含任何有效数据
vbInteger 2 Integer
vbLong 3 长整数
vbSingle 4 单精度浮点数
vbDouble 5 双精度浮点数
vbCurrency 6 Currency
vbDate 7 Date
vbString 8 String
vbObject 9 对象
vbError 10 错误
vbBoolean 11 布尔
vbVariant 12 Variant（只用于变体的数组类型）
vbDataObject 13 数据访问对象
vbDecimal 14 Decimal
vbByte 17 Byte
vbUserDefinedType 36 包含用户定义类型的变量
vbArray 8192 数组
TypeName 函数
返回一个 String，提供有关变量的信息。
语法: TypeName(varname)
必要的 varname 参数是一个 Variant，它包含用户定义类型变量之外的任何变量。
TypeName 所返回的字符串可以是下面列举的任何一个字符串：
返回字符串 变量
<object type> 类型为 objecttype 的对象
Byte 位值
Integer 整数
Long 长整数
Single 单精度浮点数
Double 双精度浮点数
Currency 货币
Decimal 十进制值
Date 日期
String 字符串
<Boolean> 布尔值:False 或 True
Error 错误值
Empty 未初始化
Null 无效数据
Object 对象
Unknown 类型未知的对象
Nothing 不再引用对象的对象变量
如果 varname 是一个数组，则返回的字符串可以是任何一个后面添加了空括号的可能的返回字符串（或 Variant）。例如，如果 varname 是一个整数数组，则 TypeName 返回 "Integer()"。
--------------------------------------------------------
VB工程组成结构
文件扩展名及描述
.bas基本模块
.cls类模块
.ctl用户控件文件
.ctx用户控件的二进制文件
.dca活动的设计器的高速缓存
.ddf打包和扩展向导CAB信息文件
.dep打包和展开向导从属文件
.dll运行中的AvtiveX部件
.dobAvtiveX文档窗体文件
.doxAvtiveX文档二进制窗体文件
.dsr活动的设计器文件
.dsx活动的设计器的二进制文件
.dws部署向导教本文件
.exe可执行文件或AvtiveX部件
.frm窗体文件
.frx二进制窗体文件
.log加载错误的日志文件
.oca控件类型库缓存文件
.ocxAvtiveX控件
.pag属性页文件
.pgx二进制属性页文件
.res资源文件
.tlb远程自动化类型库文件
.vbdAvtiveX文档状态文件
.vbgVisual Basic组工程文件
.vbl控件许可文件
.vbpVisual Basic工程文件
.vbr远程自动化注册文件
.vbwVisual Basic工程工作空间文件
.vbz向导发射文件
.wctWebClass HTML模板
-----------------------------------------------
"!"感叹号与"."圆点的用法差异
都用在对象的属性等的引用上.
圆点操作符"."用来表示对象的属性和方法,在引用时需要用在对象的名称、圆点和需要的属性和方法.例如引用按钮的Caption属性:Command1.Caption
感叹号"!"常用于一个控件作为一个特性访问的情况下,例如引用另一窗体中的TextBox的Text属性:Form2!Text1.Text,用"!"连接两个控件,且前者是后者的容器.值得注意的是这里如果使用"."替换"!",可以获得同样效果.为了提高代码可读性,用"!"吧.
------------------------------------------
动态数组相关
'介绍如何声明动态数组,以及保留动态数组的内容
'声明动态数组
Dim MyArray() As Integer
Private Sub Form_Load()
Dim i As Integer
Dim j As Integer
j = 5
'重定数组数维大小
ReDim MyArray(j)
Debug.Print "当前数维:", UBound(MyArray)
For i = 0 To j
'初始化数组
MyArray(i) = i
Debug.Print MyArray(i)
Next
'若要再次重定数维大小,而且要保留原有数据
'那么,用关键字 Preserve,但它只能重定最末维大小
j = j + 5
ReDim Preserve MyArray(j)
Debug.Print "当前数维:", UBound(MyArray)
'查看数据
For i = j - 5 To j
MyArray(i) = i
Debug.Print MyArray(i)
Next
Debug.Print "全部数据:"
For i = 0 To j
Debug.Print MyArray(i)
Next
End Sub
----------------------------------------------------
遍历所有控件和判断控件类型
Private Sub Form_DblClick()
'定义对象
Dim ctl As Control
'遍历所有控件
For Each ctl In Me 'For Each ctl In Me.Controls
'根据类型,改变属性值
If TypeOf ctl Is TextBox Then
ctl.Text = "文本框" & ctl.Text
ElseIf TypeOf ctl Is Label Then
ctl.Caption = "标签" & ctl.Caption
ElseIf TypeOf ctl Is CommandButton Then
ctl.Caption = "按钮" & ctl.Caption
End If
Next
End Sub
VB的坐标系统综述
由于在visual basic系统中有多种坐标定义,容易使初学者混淆,本文将详细总结vb的坐标系统的一些基本概念，并提供坐标定义的详细方法：
visual basic 坐标系统概述：
visual basic 的坐标系统是指在屏幕（screen）、窗体(form)、容器(container)上定义的表示图形对象位置的平面二维格线，一般采用数对（x,y）的形式定位。其中，x 值是沿 x 轴点的位置，最左端是缺省位置 0。y 值是沿 y 轴点的位置，最上端是缺省位置 0。
在visual basic坐标系中，沿坐标轴定义位置的测量单位，统称为刻度，坐标系统的每个轴都有自己的刻度。坐标轴的方向、起点和刻度都是可变的,在后面的叙述中，将讨论如何改变这些定义。
如何创建坐标系统:
创建图形对象的坐标系统，一般有以下几种方法：
1、使用系统缺省定义：
在系统缺省状态下，visual basic使用twips坐标系，以’缇’为单位(1缇的长度等于1/1440英寸；1/567厘米;1/20磅)。应当注意的是：这些值指示的是图形对象打印尺寸的大小。而在计算机屏幕上的物理距离则根据监视器的大小及分辨率的变化而变化。
2、选择系统标准刻度定义：
除了缺省的twips坐标系外，用户还可以通过对象的scalemode属性来设置其它的坐标刻度：（共有8种设置），现将这些设置列表如下：
scalemode值 表示 说明
0 user 用户自定义
1 twip 缇，系统缺省设置
2 point 磅，每英寸约为72磅
3 pixel 像素，像素是监视器或打印机分率的最小单位。每英寸里像素的数目由系统设备的分辨率决定。
4 character 字符，打印时，一个字符高 1/6 英寸，宽1/12 英寸
5 inch 英寸，每英寸为2.54厘米
6 millimeter 毫米
7 centimeter 厘米
在上述设置值中，除了 0 和 3以外，其它所有模式都是打印机所打印的单位长度。例如，某对象长为4个单位，当 scalemode 设为 5 时，打印时就是4英寸长。在程序中设定scalemode值的代码如下：
'设窗体的刻度单位为厘米。
scalemode = 7
'设 picture1 的刻度单位为像素。
picture1.scalemode = 3
3、创建自定义坐标系统：
当scalemode=0时，即为用户自定义模式，可采用设置对象的相应属性，来创建所需的坐标系统,这些属性是：
scaleleft: 设置对象左边距值
scaletop: 设置对象上边距值
scalewidth: 设置对象宽度
scaleheight: 设置对象高度
下面给出如下设置代码：
scaleleft=100
scaletop=100
scalewidth=300
scaleheight=200
picture1.scaleleft=50
picture1.scaletop=50
则所定义的坐标系如下图所示：
scaletop=100
picture1.scaleleft=50
以上代码定义窗体左上角坐标为（100，100），定义窗体内图形对象picture1距窗体左边距离为50，上边距离为50。scalewidth 和 scaleheight 语句定义窗体内部宽度的 1/300 为水平坐标单位；当前窗体内部高度的 1/200 为垂直坐标单位。如果窗体的大小以后被调整，这些单位保持原状。也就是说：scalewidth 和 scaleheight 是按照对象的内部尺寸来定义单位的，并且这些尺寸不包括边框厚度或菜单标题的高度。scalewidth 和 scaleheight 是指对象内的可用空间的大小。它们决定了对象本身的坐标系统。这有别于内部尺寸和外部尺寸（由 width 和 height属性指定）定义，width 和 height 总是按照容器的坐标系统来表示。另外以上刻度属性都可包括分数，也可是负数。如果将 scalewidth 和 scaleheight 属性设置值为负数即改变坐标系统的方向。
4．使用scale方法定义坐标系统：
一个更简洁的改变坐标系统的途径是使用 scale 方法。定义形式如下：
[object.]scale (x1, y1) – (x2, y2)
x1 和 y1 的值，决定了 scaleleft 和 scaletop 属性的设置值。x2-x1的差值和y2-y1的差值，分别决定了 scalewidth 和 scaleheight 属性的设置值。若指定 x1 > x2 或 y1 > y2 的值，与设置 scalewidth 或 scaleheight 为负值的效果相同。例如：设定窗体坐标系统如下：
scale (100, 100)-(200, 200)
该语句定义等同于以下属性设置：
scaletop=100:scaleleft=100:scalewidth=100:scaleheight=100
如何恢复缺省坐标系统：
在定义了其它坐标系后，如果需要将坐标系统恢复为缺省的twips坐标系，可以使用不含参数的scale方法，如语句：
picture1.scale
将图形对象的坐标系统恢复为缺省，其左上角坐标为（0，0）。
---------------------------------------------------------
键码
键码
常数 值 描述
vbKeyLButton 1 鼠标左键
vbKeyRButton 2 鼠标右键
vbKeyCancel 3 CANCEL 键
vbKeyMButton 4 鼠标中键
vbKeyBack 8 BACKSPACE 键
vbKeyTab 9 TAB 键
vbKeyClear 12 CLEAR 键
vbKeyReturn 13 ENTER 键
vbKeyShift 16 SHIFT 键
vbKeyControl 17 CTRL 键
vbKeyMenu 18 菜单键
vbKeyPause 19 PAUSE 键
vbKeyCapital 20 CAPS LOCK 键
vbKeyEscape 27 ESC 键
vbKeySpace 32 SPACEBAR 键
vbKeyPageUp 33 PAGEUP 键
vbKeyPageDown 34 PAGEDOWN 键
vbKeyEnd 35 END 键
vbKeyHome 36 HOME 键
vbKeyLeft 37 LEFT ARROW 键
vbKeyUp 38 UP ARROW 键
vbKeyRight 39 RIGHT ARROW 键
vbKeyDown 40 DOWN ARROW 键
vbKeySelect 41 SELECT 键
vbKeyPrint 42 PRINT SCREEN 键
vbKeyExecute 43 EXECUTE 键
vbKeySnapshot 44 SNAP SHOT 键
vbKeyInser 45 INS 键
vbKeyDelete 46 DEL 键
vbKeyHelp 47 HELP 键
vbKeyNumlock 144 NUM LOCK 键
A 键到 Z 键与其 ASCII 码的相应值'A' 到 'Z' 是一致的
常数 值 描述
vbKeyA 65 A 键
vbKeyB 66 B 键
vbKeyC 67 C 键
vbKeyD 68 D 键
vbKeyE 69 E 键
vbKeyF 70 F 键
vbKeyG 71 G 键
vbKeyH 72 H 键
vbKeyI 73 I 键
vbKeyJ 74 J 键
vbKeyK 75 K 键
vbKeyL 76 L 键
vbKeyM 77 M 键
vbKeyN 78 N 键
vbKeyO 79 O 键
vbKeyP 80 P 键
vbKeyQ 81 Q 键
vbKeyR 82 R 键
vbKeyS 83 S 键
vbKeyT 84 T 键
vbKeyU 85 U 键
vbKeyV 86 V 键
vbKeyW 87 W 键
vbKeyX 88 X 键
vbKeyY 89 Y 键
vbKeyZ 90 Z 键
0 键到 9 键与其 ASCII 码的相应值 '0' 到 '9' 是一致的
常数 值 描述
vbKey0 48 0 键
vbKey1 49 1 键
vbKey2 50 2 键
vbKey3 51 3 键
vbKey4 52 4 键
vbKey5 53 5 键
vbKey6 54 6 键
vbKey7 55 7 键
vbKey8 56 8 键
vbKey9 57 9 键
数字小键盘上的键
常数 值 描述
vbKeyNumpad0 96 0 键
vbKeyNumpad1 97 1 键
vbKeyNumpad2 98 2 键
vbKeyNumpad3 99 3 键
vbKeyNumpad4 100 4 键
vbKeyNumpad5 101 5 键
vbKeyNumpad6 102 6 键
vbKeyNumpad7 103 7 键
vbKeyNumpad8 104 8 键
vbKeyNumpad9 105 9 键
vbKeyMultiply 106 乘号 (*) 键
vbKeyAdd 107 加号 (+) 键
vbKeySeparator 108 ENTER 键（在数字小键盘上）
vbKeySubtract 109 减号 (-) 键
vbKeyDecimal 110 小数点 (.) 键
vbKeyDivide 111 除号 (/) 键
功能键
常数 值 描述
vbKeyF1 112 F1 键
vbKeyF2 113 F2 键
vbKeyF3 114 F3 键
vbKeyF4 115 F4 键
vbKeyF5 116 F5 键
vbKeyF6 117 F6 键
vbKeyF7 118 F7 键
vbKeyF8 119 F8 键
vbKeyF9 120 F9 键
vbKeyF10 121 F10 键
vbKeyF11 122 F11 键
vbKeyF12 123 F12 键
vbKeyF13 124 F13 键
vbKeyF14 125 F14 键
vbKeyF15 126 F15 键
vbKeyF16 127 F16 键
以下是我的一个安装包的注释内容:
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;下面的注释包含自解压脚本命令
Path=xufengn635 v2.0
SavePath
Setup=xfn6353.exe
Overwrite=1
Title=庆晓资料运算工具 2.0 安装程序
Text
{
《庆晓资料运算工具 ver 2.0 最终用户许可协议》
首先你必须承认：世界上没有烤不熟的地瓜，以表明你与作者就
地瓜一事已达成共识。
其次，(此处略去)
联系作者：旭峰
E-mail: kxufeng@163.com
}
Shortcut=D, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0"
Shortcut=P, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0"
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
用WinRar制作自释放压缩包,可以同样有安装界面,同样可以创建快捷键,可以有反安装项,仅把需要的几个部件加进去就行了.体积不会很大,适用于一些免费软件.上述安装包仅1.25M,一张软盘就可以带走.在win98-2上(没有装过任何VB类型程序的系统)运行都可以通过.
其中包括的组件及描述:
xfn6353.exe主程序(form 3个,用户控件 2个,image 若干,picturebox 8个,Label 若干,combobox 若干,timer ...)704k
MSVBVM60.DLL运行库(我们用的很多函数和一些基本控件,诸如Mid,UCase,Shell,Left,Right...都在里面) 1.34M
PICCLP32.OCX因为做了个动画,用到了PictureClip,所以连控件一并打包 81.1k
help.chm帮助文件 446k
Sound目录有几个WAV在里面 40k
n635.ico图标,工程和压缩包都用到(为了减小体积,要把图标文件中不需要的24X,48X,真彩色等图层全部去掉.仅保留16X 256色和32X 256色两层)
要注意的是,有些不能自我注册的Dll或OCX,可以写个BAT文件解压后自动运行执行注册:
regsvr32 abcd.dll
rem regsvr32 /u abcd.dll
@exit
(那个regsvr32.exe要13k大小,第二行被注释掉的是反注册命令)
---------------------------------------------------------------
磁盘序号
'Form Code:
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Function GetSerialNumber(strDrive As String) As Long
Dim SerialNum As Long
Dim Res As Long
Dim Temp1 As String
Dim Temp2 As String
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
Res = GetVolumeInformation(strDrive, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
GetSerialNumber = SerialNum
End Function
Private Sub form_load()
'使用该函数:
MsgBox GetSerialNumber("c:/")
'它将告诉你C驱的磁盘序号。
End Sub
--------------------------------------------------------
获取所有驱动器类型
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Demo_Frm
Caption = "Demo"
ClientHeight = 2670
ClientLeft = 3795
ClientTop = 1905
ClientWidth = 4035
LinkTopic = "Form1"
ScaleHeight = 2670
ScaleWidth = 4035
Tag
最低0.47元/天 解锁文章
4517
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
