VB不错的代码 vb net和vb的代码区别
'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= "大小"
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 所返回的字符串可以是下面列举的任何一个字符串:
返回字符串 变量
更多阅读
发泥和发蜡有什么区别 该如何选择 发泥和发蜡的区别
发泥和发蜡有什么区别 该如何选择——简介 其实发泥和发蜡效果很相似,不同的发质,头发长度你剪得发型和你需要创造的效果以及操作手法都会使后面出来的效果大不一样。听完小编的分析,如何选择就看哪个更适合你自己吧!发泥和发蜡有什么
借记卡和信用卡有什么区别 借记卡和储蓄卡的区别
借记卡和信用卡有什么区别——简介借记卡和信用卡有何不同?借记卡和信用卡的区别是什么呢?为了让卡友们分期借记卡和信用卡,来为卡友们详细介绍一下。借记卡和信用卡有什么区别——方法/步骤借记卡和信用卡
鸡眼和跖疣怎么区别?鸡眼和跖疣的区别图片? 鸡眼和跖疣的区别图
鸡眼和跖疣怎么区别?鸡眼和跖疣的区别图片?——简介鸡眼极为常见,多数人都见过。鸡眼也很好治,一般的药店有鸡眼膏,自己贴上就能治好;但有很多人鸡眼治了很久没好,反而越长越多的,去医院看了,认断跖疣;在我们皮肤科门诊,也经常会遇到患者把跖疣
闲谈ape和mp3之间的音质区别 ape与mp3的区别
好久没写文章了,和朋友们闲聊几句。 随着兼容播放无损音频播放机的上市,APE的用途越来越大了。记得当初我们取消MP3版块交流的时候,有很多朋友不理解,认为MP3和APE之间的音质区别不大。为此,我的一位好朋友还辞去了版主职务。这2年,APE
路由器和交换机有什么区别 交换机和路由器的区别
路由器和交换机有什么区别——简介随着社会的发展,很多家庭都拥有2台或者数台电脑,为了实现电脑的共同上网,路由器和交换机也慢慢的被更多人认知,但是由于家用路由器和交换机从外面看起来很像,很多人都不知道路由器和交换机的区别,以及各