VB不错的代码 vb net和vb的代码区别

发布时间：2024年11月06日 14:17:28分享人:不服气来源:互联网13
实现毫秒精度的延时

'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 AsLong
HighPart AsLong
End Type

'实现毫秒量级精确延时,(n 毫秒)
Public Sub Wait(ByVal n As Long)
DimPFrequency As LARGE_INTEGER
Dim IntervalAs LARGE_INTEGER
Dim PriviousAs LARGE_INTEGER
Dim CurrentAs 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

'延时
Wait5000

'停止计时
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 AsString
str ="字符串第一个字的地址:"
Print str,StrPtr(str)

Print"----------------------------------"
Dim ramid AsDouble
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.PrintChnNumber(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为简单排列(壹贰叁零零点肆叁/一二三○○点四三)

IfAbs(Number) > CDbl(9.99999999999999E+15) Then
'9999兆9999万9990 or 9999999999999990 or 9.99999999999999E+15
MsgBox "超出这个范围的数字,将会有四舍五入进位情况。" & Space(5) & vbCrLf &_
"难道你...要计算星星的数量?偶帮不了你啦",vbInformation, "老兄:天文数字啊"
'Exit Function
End If

DimvarNumber As Variant
DimChnString(1) As String, strClass(1) As String
DimiNumberLen As Integer, iCapital As Integer
Dim boolZeroAs Boolean
Dim strTempAs String
Dim i AsInteger, 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 SimpleThen
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

IfiNumberLen < 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 ThenstrTemp = ""
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
'处理小数部分
IfUBound(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
IfLen(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:WINDOWSsystem32stdole2.tlb#OLEAutomation
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.PictureBoxPicture1
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
WithTray
.TipText = Me.Caption'提示文本
.PicBox = Picture1'一个用于托盘的图标(PictureBox)
EndWith
Tray.ShowIcon '添加图标在托盘
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode AsInteger)
'删除托盘图标
Tray.DeleteIcon
Set Tray =Nothing
End Sub

Private Sub m_exit_Click()
UnloadMe
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()
'右键放开
PopupMenutempmenu
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 AsLong
hWnd AsLong
lId AsLong
lFlags AsLong
lCallBackMessage As Long
hIcon AsLong
szTip AsString * 64
End Type

Private mNID As NOTIFYICONDATA
Private WithEvents mPic As PictureBox
Attribute mPic.VB_VarHelpID = -1

Public EventRButtonDown()'鼠标右键按下
Public EventRButtonUp()'鼠标右键放开
Public Event RButtonDblClick() '鼠标右键双击
Public EventLButtonDown()'鼠标左键按下
Public EventLButtonUp()'鼠标左键放开
Public Event LButtonDblClick() '鼠标左键双击

Private Sub Class_Initialize()
WithmNID
.lSize = Len(mNID)
.lCallBackMessage = WM_MOUSEMOVE
.lFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.lId = 1&
EndWith
End Sub

Private Sub Class_Terminate()
DeleteIcon
Set mPic =Nothing
End Sub

Public Property Let PicBox(ByVal PicBox As PictureBox)
Set mPic =PicBox
WithmNID
.hWnd = mPic.hWnd
.hIcon = mPic
EndWith
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 IsNothing 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, XAs Single, Y As Single)
Static bRecAs Boolean
Dim lMsg AsLong

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()
'如果指定文件夹不存在,则创建
IfDir("c:mydos", vbDirectory) = "" Then MkDir "c:mydos"'在硬盘上新建一个c:mydos的文件夹。
'调用指令,复制一批文件到该文件夹下(需具备xcopy.exe)
Shell"xcopy.exe C:WINDOWSWebWallpaper*.* 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:WINDOWSsystem32stdole2.tlb#OLEAutomation
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= "大小"
VB不错的代码 vb net和vb的代码区别
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()
IfWindowState = vbMinimized Then
LastState = vbNormal
Else
LastState = WindowState
End If
AddToTrayMe, mnuTray
SetTrayTip"VB Helper tray icon program"
End Sub

Private Sub Form_Resize()
Select CaseWindowState
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
EndSelect

IfWindowState <> vbMinimized Then _
LastState = WindowState
End Sub

Private Sub Form_Unload(Cancel As Integer)
RemoveFromTray
End Sub

Private Sub mnuFileExit_Click()
UnloadMe
End Sub

Private Sub mnuTrayClose_Click()
UnloadMe
End Sub

Private Sub mnuTrayMaximize_Click()
WindowState= vbMaximized
End Sub

Private Sub mnuTrayMinimize_Click()
WindowState= vbMinimized
End Sub

Private Sub mnuTrayMove_Click()
SendMessagehwnd, WM_SYSCOMMAND, SC_MOVE, 0&
End Sub

Private Sub mnuTrayRestore_Click()
SendMessagehwnd, WM_SYSCOMMAND, SC_RESTORE, 0&
End Sub

Private Sub mnuTraySize_Click()
SendMessagehwnd, 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 AsLong, _
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 AsLong
hwnd AsLong
uID AsLong
uFlags AsLong
uCallbackMessage As Long
hIcon AsLong
szTip AsString * 64
End Type

Private TheData As NOTIFYICONDATA

Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg AsLong, _
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, AddressOfNewWindowProc)
WithTheData
.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)
EndWith
Shell_NotifyIcon NIM_ADD, TheData
End Sub

Public Sub RemoveFromTray()
WithTheData
.uFlags = 0
EndWith
Shell_NotifyIcon NIM_DELETE, TheData

SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProc
End Sub

Public Sub SetTrayTip(tip As String)
WithTheData
.szTip = tip & vbNullChar
.uFlags = NIF_TIP
EndWith
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub

Public Sub SetTrayIcon(pic As Picture)
If pic.Type<> vbPicTypeIcon Then Exit Sub

WithTheData
.hIcon = pic.Handle
.uFlags = NIF_ICON
EndWith
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 AsITEMIDLIST) As Long
Type SHITEMID
cb AsLong
abID() AsByte
End Type
Type ITEMIDLIST
mkid AsSHITEMID
End Type

Public Function MyDocumentsDir(oForm As Form) As String
Dim IDL AsITEMIDLIST
Dim sPath AsString * 260
IfSHGetSpecialFolderLocation(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 AsString) As Integer
'返回两列间隔数(Excel表中的列)
Dim a AsInteger, b As Integer
IfLen(RangeNameA) = 0 Or Len(RangeNameB) = 0 Then Exit Function
RangeNameA =UCase(RangeNameA)
RangeNameB =UCase(RangeNameB)
IfLen(RangeNameA) = 1 Then
a = Asc(RangeNameA) - 64
Else
a = (Asc(Left(RangeNameA, 1)) - 64) * 26 + Asc(Right(RangeNameA,1)) - 64
End If
IfLen(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 AsInteger, j As Integer
For i = 1 ToLen(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 AsString) As String
'获取文件路径中的路径部分 和 文件名部分
'调用:
'Dim filedirAs String
'Debug.Print"文件名:", FileNameIs("c:abc.txt", filedir)
'Debug.Print"路径:", filedir

IfLen(AllFileDir) = 0 Then FileDirIs = "": Exit Function

Dim v AsVariant
Dim i AsInteger
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 AsLong, _
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 AsLong, _
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), AddressOfNewWindowProc)


-----------------------------------------------------

用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 AsLong)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA"_
(ByVal lpString1 As String, ByVal lpString2 As String) AsLong
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi AsBrowseInfo) 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 AsString) As String
Dim iNull AsInteger
Dim lpIDListAs Long
Dim lResultAs Long
Dim sPath AsString
Dim udtBI AsBrowseInfo

WithudtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
EndWith

lpIDList =SHBrowseForFolder(udtBI)

If lpIDListThen
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()
DimsDirectoryName As String
sDirectoryName = BrowseForFolder(Me.hWnd, "请选择目录")
Debug.PrintsDirectoryName
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 所返回的字符串可以是下面列举的任何一个字符串：

返回字符串 变量

类型为 objecttype 的对象
Byte 位值
Integer 整数
Long 长整数
Single 单精度浮点数
Double 双精度浮点数
Currency 货币
Decimal 十进制值
Date 日期
String 字符串
布尔值: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 AsInteger
Dim j AsInteger
j = 5
'重定数组数维大小
ReDimMyArray(j)
Debug.Print"当前数维:", UBound(MyArray)

For i = 0 Toj
'初始化数组
MyArray(i) = i
Debug.Print MyArray(i)
Next


'若要再次重定数维大小,而且要保留原有数据
'那么,用关键字Preserve,但它只能重定最末维大小
j = j +5
ReDimPreserve 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 Toj
Debug.Print MyArray(i)
Next
End Sub


----------------------------------------------------

遍历所有控件和判断控件类型


Private Sub Form_DblClick()
'定义对象
Dim ctl AsControl
'遍历所有控件
For Each ctlIn Me 'For Each ctl InMe.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的坐标系统综述

由于在visualbasic系统中有多种坐标定义,容易使初学者混淆,本文将详细总结vb的坐标系统的一些基本概念，并提供坐标定义的详细方法：

visual basic 坐标系统概述：

visual basic的坐标系统是指在屏幕（screen）、窗体(form)、容器(container)上定义的表示图形对象位置的平面二维格线，一般采用数对（x,y）的形式定位。其中，x 值是沿 x 轴点的位置，最左端是缺省位置 0。y 值是沿 y 轴点的位置，最上端是缺省位置 0。

在visualbasic坐标系中，沿坐标轴定义位置的测量单位，统称为刻度，坐标系统的每个轴都有自己的刻度。坐标轴的方向、起点和刻度都是可变的,在后面的叙述中，将讨论如何改变这些定义。

如何创建坐标系统:

创建图形对象的坐标系统，一般有以下几种方法：

1、使用系统缺省定义：

在系统缺省状态下，visualbasic使用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,真彩色等图层全部去掉.仅保留16X256色和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 AsString, _
ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long,_
lpMaximumComponentLength As Long, lpFileSystemFlags As Long,_
ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSizeAs Long) As Long

Function GetSerialNumber(strDrive As String) As Long
DimSerialNum As Long
Dim Res AsLong
Dim Temp1 AsString
Dim Temp2 AsString
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= "hello"
Begin VB.ListBox List1
Height= 2040
Left= 120
TabIndex= 1
Top= 240
Width= 3855
End
Begin VB.CommandButtonCommand1
Caption= "获取信息"
Height= 375
Left= 1440
TabIndex= 0
Top= 2280
Width= 975
End
End
Attribute VB_Name = "Demo_Frm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetLogicalDriveStrings Lib "kernel32"Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) AsLong
Private Declare Function GetDriveType Lib "kernel32" Alias"GetDriveTypeA" _
(ByVal nDrive As String) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () AsLong

Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_NO_ROOT_DIR = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6

'　　用来返回磁盘驱动器的个数
Public Function DriveCount() As Integer
Dim BitMaskAs Long
Dim j,i

BitMask =GetLogicalDrives()
For i = 0 To24
If BitMask And 2 ^ i Then
j = j + 1
End If
Next i
DriveCount =j
End Function

' 返回驱动器的名称
Public Function LoadDrivenames(An_Array() As String) As Long
Dim j,i
Dim lpBufferAs String

ReDimAn_Array(128) As String
lpBuffer =Space$(1024)
' 返回当前所有逻辑驱动器的根驱动器路径
GetLogicalDriveStrings Len(lpBuffer), lpBuffer
j =InStr(lpBuffer, Chr$(0))
' 存储磁盘驱动器的名称到An_Array中
Do While j> 0
An_Array(i) = Left$(lpBuffer, j - 1)
i = i + 1
lpBuffer = Mid$(lpBuffer, j + 1)
j = InStr(lpBuffer, Chr$(0))
Loop
ReDimPreserve An_Array(DriveCount)
End Function

' 返回磁盘驱动器的类型
Public Function Types(Optional sDrive As String) As String
Select CaseGetDriveType(sDrive)
Case DRIVE_UNKNOWN
Types = "不能识别"
Case DRIVE_NO_ROOT_DIR
Types = "不存在"
Case DRIVE_REMOVABLE
Types = "可移除驱动器"
Case DRIVE_FIXED
Types = "固定驱动器"
Case DRIVE_REMOTE
Types = "远程驱动器"
Case DRIVE_CDROM
Types = "光盘驱动器"
Case DRIVE_RAMDISK
Types = "随机存取磁盘"
Case Else
Types = "ERROR"
EndSelect
End Function

Private Sub Command1_Click()
DimDrivesN() As String
Dim i AsInteger

Me.Cls
Print"驱动器个数:" & DriveCount
CallLoadDrivenames(DrivesN)
For i = 0 ToDriveCount - 1
List1.AddItem DrivesN(i) & Types(DrivesN(i))
Next i
End Sub


-------------------------------------------------
ComboBox加长加宽下拉选单
'form code:
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidthAs Long, _
ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias"SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long,lParam As Long) As Long
Const CB_SETDROPPEDWIDTH = &H160

' 设置ComboBox下拉选单长度函数
Public Sub SetComboHeight(ComboBox_Obj As ComboBox, NewHeight AsLong)
DimOldScaleMode As Integer
If TypeOfComboBox_Obj.Parent Is Frame Then Exit Sub
'改变ComboBox控件的容器的坐标度量单位为象素
OldScaleMode= ComboBox_Obj.Parent.ScaleMode
ComboBox_Obj.Parent.ScaleMode = vbPixels
'重新定义ComboBox的尺寸
MoveWindowComboBox_Obj.hwnd, ComboBox_Obj.Left, _
ComboBox_Obj.Top, ComboBox_Obj.Width, NewHeight, 1
'恢复ComboBox控件的容器的坐标度量单位
ComboBox_Obj.Parent.ScaleMode = OldScaleMode
End Sub

' 设置ComboBox下拉选单宽度函数
Public Sub SetComboWidth(ComboBox_Obj As ComboBox, NewWidth AsLong)
' NewWidth 是宽度，单位是 pixels
SendMessageComboBox_Obj.hwnd, CB_SETDROPPEDWIDTH, NewWidth, 0
End Sub

Private Sub Form_Load()
Dim i AsInteger
' 向ComboBox添加项
For i = 0 To40
Combo1.AddItem ("This is the long Item " + CStr(i))
Next i
End Sub

' 改变ComboBox下拉选单长度和宽度
Private Sub Change_But_Click()
CallSetComboHeight(Combo1, 300)
CallSetComboWidth(Combo1, 200)
End Sub



获取硬盘序列号、生产厂家/型号
【Class Code:将下面代码用记事本保存为 CDiskInfo.cls(类模块文件),此括弧及括弧内容除外】
Option Explicit

'http://vip.6to23.com/NowCan1/tech/vb_hd_info.htm
'--------------------------------------------------------------------------
' 类模块： CDiskInfo.cls
' 功能说明：获取硬盘序列号、生产厂家/型号
' 注意事项：支持Windows 95 OSR2,Windows 98, Windows NT, Windows 2000
'XP没有测试，估计没问题，在Win9X下必须保证存在SMARTVSD.vxd
'--------------------------------------------------------------------------

Private Const MAX_IDE_DRIVES As Long = 4
Private Const READ_ATTRIBUTE_BUFFER_SIZE As Long = 512
Private Const IDENTIFY_BUFFER_SIZE As Long = 512
Private Const READ_THRESHOLD_BUFFER_SIZE As Long = 512
Private Const DFP_GET_VERSION As Long = &H74080
Private Const DFP_SEND_DRIVE_COMMAND As Long = &H7C084
Private Const DFP_RECEIVE_DRIVE_DATA As Long = &H7C088

Private Type GETVERSIONOUTPARAMS
bVersion AsByte
bRevision AsByte
bReserved AsByte
bIDEDeviceMap As Byte
fCapabilities As Long
dwReserved(3) As Long
End Type

Private Const CAP_IDE_ID_FUNCTION As Long = 1
Private Const CAP_IDE_ATAPI_ID As Long = 2
Private Const CAP_IDE_EXECUTE_SMART_FUNCTION As Long = 4

Private Type IDEREGS
bFeaturesRegAs Byte
bSectorCountReg As Byte
bSectorNumberReg As Byte
bCylLowRegAs Byte
bCylHighRegAs Byte
bDriveHeadReg As Byte
bCommandRegAs Byte
bReserved AsByte
End Type

Private Type SENDCMDINPARAMS
cBufferSizeAs Long
irDriveRegsAs IDEREGS
bDriveNumberAs Byte
bReserved(2)As Byte
dwReserved(3) As Long
bBuffer(0)As Byte
End Type

Private Const IDE_ATAPI_ID As Long = &HA1
Private Const IDE_ID_FUNCTION As Long = &HEC
Private Const IDE_EXECUTE_SMART_FUNCTION As Long = &HB0
Private Const SMART_CYL_LOW As Long = &H4F
Private Const SMART_CYL_HI As Long = &HC2

Private Type DRIVERSTATUS
bDriverErrorAs Byte
bIDEStatusAs Byte
bReserved(1)As Byte
dwReserved(1) As Long
End Type

Private Const SMART_NO_ERROR As Long = 0
Private Const SMART_IDE_ERROR As Long = 1
Private Const SMART_INVALID_FLAG As Long = 2
Private Const SMART_INVALID_COMMAND As Long = 3
Private Const SMART_INVALID_BUFFER As Long = 4
Private Const SMART_INVALID_DRIVE As Long = 5
Private Const SMART_INVALID_IOCTL As Long = 6
Private Const SMART_ERROR_NO_MEM As Long = 7
Private Const SMART_INVALID_REGISTER As Long = 8
Private Const SMART_NOT_SUPPORTED As Long = 9
Private Const SMART_NO_IDE_DEVICE As Long = 10

Private Type SENDCMDOUTPARAMS
cBufferSizeAs Long
drvStatus AsDRIVERSTATUS
bBuffer(0)As Byte
End Type

Private Const SMART_READ_ATTRIBUTE_VALUES As Long = &HD0
Private Const SMART_READ_ATTRIBUTE_THRESHOLDS As Long =&HD1
Private Const SMART_ENABLE_DISABLE_ATTRIBUTE_AUTOSAVE As Long =&HD2
Private Const SMART_SAVE_ATTRIBUTE_VALUES As Long = &HD3
Private Const SMART_EXECUTE_OFFLINE_IMMEDIATE As Long =&HD4
Private Const SMART_ENABLE_SMART_OPERATIONS As Long =&HD8
Private Const SMART_DISABLE_SMART_OPERATIONS As Long =&HD9
Private Const SMART_RETURN_SMART_STATUS As Long = &HDA

Private Type DRIVEATTRIBUTE
bAttrID AsByte
wStatusFlagsAs Integer
bAttrValueAs Byte
bWorstValueAs Byte
bRawValue(5)As Byte
bReserved AsByte
End Type

Private Type ATTRTHRESHOLD
bAttrID AsByte
bWarrantyThreshold As Byte
bReserved(9)As Byte
End Type

Private Type IDSECTOR
wGenConfigAs Integer
wNumCyls AsInteger
wReserved AsInteger
wNumHeads AsInteger
wBytesPerTrack As Integer
wBytesPerSector As Integer
wSectorsPerTrack As Integer
wVendorUnique(2) As Integer
sSerialNumber(19) As Byte
wBufferTypeAs Integer
wBufferSizeAs Integer
wECCSize AsInteger
sFirmwareRev(7) As Byte
sModelNumber(39) As Byte
wMoreVendorUnique As Integer
wDoubleWordIO As Integer
wCapabilities As Integer
wReserved1As Integer
wPIOTimingAs Integer
wDMATimingAs Integer
wBS AsInteger
wNumCurrentCyls As Integer
wNumCurrentHeads As Integer
wNumCurrentSectorsPerTrack As Integer
ulCurrentSectorCapacity(3) As Byte
wMultSectorStuff As Integer
ulTotalAddressableSectors(3) As Byte
wSingleWordDMA As Integer
wMultiWordDMA As Integer
bReserved(127) As Byte
End Type

Private Const ATTR_INVALID As Long = 0
Private Const ATTR_READ_ERROR_RATE As Long = 1
Private Const ATTR_THROUGHPUT_PERF As Long = 2
Private Const ATTR_SPIN_UP_TIME As Long = 3
Private Const ATTR_START_STOP_COUNT As Long = 4
Private Const ATTR_REALLOC_SECTOR_COUNT As Long = 5
Private Const ATTR_READ_CHANNEL_MARGIN As Long = 6
Private Const ATTR_SEEK_ERROR_RATE As Long = 7
Private Const ATTR_SEEK_TIME_PERF As Long = 8
Private Const ATTR_POWER_ON_HRS_COUNT As Long = 9
Private Const ATTR_SPIN_RETRY_COUNT As Long = 10
Private Const ATTR_CALIBRATION_RETRY_COUNT As Long = 11
Private Const ATTR_POWER_CYCLE_COUNT As Long = 12
Private Const PRE_FAILURE_WARRANTY As Long = &H1
Private Const ON_LINE_COLLECTION As Long = &H2
Private Const PERFORMANCE_ATTRIBUTE As Long = &H4
Private Const ERROR_RATE_ATTRIBUTE As Long = &H8
Private Const EVENT_COUNT_ATTRIBUTE As Long = &H10
Private Const SELF_PRESERVING_ATTRIBUTE As Long = &H20
Private Const NUM_ATTRIBUTE_STRUCTS As Long = 30
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const VER_PLATFORM_WIN32s As Long = 0
Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
Private Const VER_PLATFORM_WIN32_NT As Long = 2

Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformIdAs Long
szCSDVersionAs String * 128
End Type

(待续)
(续)
Private Declare Function GetVersionEx Lib "KERNEL32" Alias"GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Const CREATE_NEW As Long = 1
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const OPEN_EXISTING As Long = 3
Private Declare Function CreateFile Lib "KERNEL32" Alias"CreateFileA" _
(ByVallpFileName As String, ByVal dwDesiredAccess As Long, _
ByValdwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByValdwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long,_
ByValhTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "KERNEL32" _
(ByValhDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any,_
ByValnInBufferSize As Long, lpOutBuffer As Any, _
ByValnOutBufferSize As Long, lpBytesReturned As Long, _
ByVallpOverlapped As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory"_
(DestinationAs Any, Source As Any, ByVal Length As Long)
Private Declare Function CloseHandle Lib "KERNEL32" _
(ByValhObject As Long) As Long
Private m_DiskInfo As IDSECTOR

Private Function OpenSMART(ByVal nDrive As Byte) As Long

DimhSMARTIOCTL As Long
Dim hd AsString
DimVersionInfo As OSVERSIONINFO

hSMARTIOCTL= INVALID_HANDLE_VALUE
VersionInfo.dwOSVersionInfoSize = Len(VersionInfo)
GetVersionExVersionInfo
Select CaseVersionInfo.dwPlatformId
Case VER_PLATFORM_WIN32s
OpenSMART = hSMARTIOCTL
Case VER_PLATFORM_WIN32_WINDOWS
'Version Windows 95 OSR2, Windows 98
hSMARTIOCTL = CreateFile("\.SMARTVSD", 0, 0, 0, CREATE_NEW, 0,0)
Case VER_PLATFORM_WIN32_NT
'Windows NT, Windows 2000
If nDrive < MAX_IDE_DRIVES Then
hd = "\.PhysicalDrive" & nDrive
hSMARTIOCTL = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
End If
EndSelect
OpenSMART =hSMARTIOCTL

End Function

Private Function DoIDENTIFY(ByVal hSMARTIOCTL As Long, _
pSCIP AsSENDCMDINPARAMS, pSCOP() As Byte, ByVal bIDCmd As Byte, _
ByValbDriveNum As Byte, lpcbBytesReturned As Long) As Boolean
'-------------------------------------------------------------------
pSCIP.cBufferSize = IDENTIFY_BUFFER_SIZE

pSCIP.irDriveRegs.bFeaturesReg = 0
pSCIP.irDriveRegs.bSectorCountReg = 1
pSCIP.irDriveRegs.bSectorNumberReg = 1
pSCIP.irDriveRegs.bCylLowReg = 0
pSCIP.irDriveRegs.bCylHighReg = 0

pSCIP.irDriveRegs.bDriveHeadReg = &HA0 Or ((bDriveNum And 1) *2 ^ 4)

pSCIP.irDriveRegs.bCommandReg = bIDCmd
pSCIP.bDriveNumber = bDriveNum
pSCIP.cBufferSize = IDENTIFY_BUFFER_SIZE
DoIDENTIFY =CBool(DeviceIoControl(hSMARTIOCTL, DFP_RECEIVE_DRIVE_DATA, _
pSCIP, 32, pSCOP(0), 528, lpcbBytesReturned, 0))

End Function

Private Function DoEnableSMART(ByVal hSMARTIOCTL As Long, _
pSCIP AsSENDCMDINPARAMS, pSCOP As SENDCMDOUTPARAMS, _
ByValbDriveNum As Byte, lpcbBytesReturned As Long) As Boolean
'---------------------------------------------------------------------
pSCIP.cBufferSize = 0
pSCIP.irDriveRegs.bFeaturesReg =SMART_ENABLE_SMART_OPERATIONS
pSCIP.irDriveRegs.bSectorCountReg = 1
pSCIP.irDriveRegs.bSectorNumberReg = 1
pSCIP.irDriveRegs.bCylLowReg = SMART_CYL_LOW
pSCIP.irDriveRegs.bCylHighReg = SMART_CYL_HI
pSCIP.irDriveRegs.bDriveHeadReg = &HA0 Or ((bDriveNum And 1) *2 ^ 4)
pSCIP.irDriveRegs.bCommandReg = IDE_EXECUTE_SMART_FUNCTION
pSCIP.bDriveNumber = bDriveNum

DoEnableSMART = CBool(DeviceIoControl(hSMARTIOCTL,DFP_SEND_DRIVE_COMMAND, _
pSCIP, LenB(pSCIP) - 1, pSCOP, LenB(pSCOP) - 1, lpcbBytesReturned,0))

End Function

Private Sub ChangeByteOrder(szString() As Byte, ByVal uscStrSize AsInteger)
Dim i AsInteger
Dim bTemp AsByte

For i = 0 TouscStrSize - 1 Step 2
bTemp = szString(i)
szString(i) = szString(i + 1)
szString(i + 1) = bTemp
Next i
End Sub

Private Sub DisplayIdInfo(pids As IDSECTOR, pSCIP AsSENDCMDINPARAMS, _
ByVal bIDCmdAs Byte, ByVal bDfpDriveMap As Byte, ByVal bDriveNum As Byte)
'--------------------------------------------------------------------------
ChangeByteOrder pids.sModelNumber, UBound(pids.sModelNumber) +1
'ChangeByteOrder pids.sFirmwareRev, UBound(pids.sFirmwareRev) +1
ChangeByteOrder pids.sSerialNumber, UBound(pids.sSerialNumber) +1
End Sub

'调用过程
Public Function GetDiskInfo(ByVal nDrive As Byte) As Long
DimhSMARTIOCTL As Long
DimcbBytesReturned As Long
DimVersionParams As GETVERSIONOUTPARAMS
Dim scip AsSENDCMDINPARAMS
Dim scop()As Byte
Dim OutCmdAs SENDCMDOUTPARAMS
DimbDfpDriveMap As Byte
Dim bIDCmdAs Byte
Dim uDisk AsIDSECTOR

m_DiskInfo =uDisk

hSMARTIOCTL= OpenSMART(nDrive)
IfhSMARTIOCTL <> INVALID_HANDLE_VALUE Then
Call DeviceIoControl(hSMARTIOCTL, DFP_GET_VERSION, ByVal 0, 0,_
VersionParams, Len(VersionParams), cbBytesReturned, 0)

If Not (VersionParams.bIDEDeviceMap 2 ^ nDrive And &H10)Then
If DoEnableSMART(hSMARTIOCTL, scip, OutCmd, nDrive,cbBytesReturned) Then
bDfpDriveMap = bDfpDriveMap Or 2 ^ nDrive
End If
End If
bIDCmd = IIf((VersionParams.bIDEDeviceMap 2 ^ nDrive And&H10), _
IDE_ATAPI_ID, IDE_ID_FUNCTION)

ReDim scop(LenB(OutCmd) + IDENTIFY_BUFFER_SIZE - 1) As Byte
If DoIDENTIFY(hSMARTIOCTL, scip, scop, bIDCmd, nDrive,cbBytesReturned) Then
CopyMemory m_DiskInfo, scop(LenB(OutCmd) - 4),LenB(m_DiskInfo)
Call DisplayIdInfo(m_DiskInfo, scip, bIDCmd, bDfpDriveMap,nDrive)
CloseHandle hSMARTIOCTL
GetDiskInfo = 1
Exit Function
End If
CloseHandle hSMARTIOCTL
GetDiskInfo = 0
Else
GetDiskInfo = -1
End If
End Function


'硬盘生产厂/型号
Public Property Get pSerialNumber() As String
pSerialNumber = StrConv(m_DiskInfo.sSerialNumber, vbUnicode)
pSerialNumber = PurString(pSerialNumber)
End Property

'硬盘序列号
Public Property Get pModelNumber() As String
pModelNumber= StrConv(m_DiskInfo.sModelNumber, vbUnicode)
pModelNumber= PurString(pModelNumber)
End Property

Private Function PurString(str As String) As String
'On ErrorResume Next
Dim i AsInteger
For i = 1 ToLen(str)
If Asc(Mid(str, i, 1)) <> 0 Then PurString = PurString &Mid(str, i, 1)
Next
PurString =Trim(PurStrin

  
有趣的vb小程序代码 

爱华网本文地址 » http://www.413yy.cn/a/25101011/95985.html

更多阅读

发泥和发蜡有什么区别 该如何选择 发泥和发蜡的区别

发泥和发蜡有什么区别 该如何选择——简介 其实发泥和发蜡效果很相似，不同的发质，头发长度你剪得发型和你需要创造的效果以及操作手法都会使后面出来的效果大不一样。听完小编的分析，如何选择就看哪个更适合你自己吧！发泥和发蜡有什么

借记卡和信用卡有什么区别 借记卡和储蓄卡的区别

借记卡和信用卡有什么区别——简介借记卡和信用卡有何不同?借记卡和信用卡的区别是什么呢?为了让卡友们分期借记卡和信用卡，来为卡友们详细介绍一下。借记卡和信用卡有什么区别——方法/步骤借记卡和信用卡

闲谈ape和mp3之间的音质区别 ape与mp3的区别

好久没写文章了，和朋友们闲聊几句。 随着兼容播放无损音频播放机的上市，APE的用途越来越大了。记得当初我们取消MP3版块交流的时候，有很多朋友不理解，认为MP3和APE之间的音质区别不大。为此，我的一位好朋友还辞去了版主职务。这2年，APE

路由器和交换机有什么区别 交换机和路由器的区别

路由器和交换机有什么区别——简介随着社会的发展，很多家庭都拥有2台或者数台电脑，为了实现电脑的共同上网，路由器和交换机也慢慢的被更多人认知，但是由于家用路由器和交换机从外面看起来很像，很多人都不知道路由器和交换机的区别，以及各

声明:《VB不错的代码 vb net和vb的代码区别》为网友不服气分享！如侵犯到您的合法权益请联系我们删除