不错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 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:[e-mail]
   
    '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:[e-mail])
Public Function LenBB(Expression As String) As Integer
    '取得字符串实际字节长度
    LenBB = LenB(StrConv(Expression, vbFromUnicode))
End Function

'-------------------------------------
'获得我的文档路径
'(作者:csdngoodnight,E-mail:[e-mail])
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:[e-mail])
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:[e-mail])
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:[e-mail])
'配合上面那个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: [e-mail]
}
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             =   "hello"
   Begin VB.ListBox List1
      Height          =   2040
      Left            =   120
      TabIndex        =   1
      Top             =   240
      Width           =   3855
   End
   Begin VB.CommandButton Command1
      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) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
        (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long

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 BitMask As Long
    Dim j, i
   
    BitMask = GetLogicalDrives()
    For i = 0 To 24
        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 lpBuffer As String
   
    ReDim An_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
    ReDim Preserve An_Array(DriveCount)
End Function

'  返回磁盘驱动器的类型
Public Function Types(Optional sDrive As String) As String
    Select Case GetDriveType(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"
    End Select
End Function

Private Sub Command1_Click()
    Dim DrivesN() As String
    Dim i As Integer
   
    Me.Cls
    Print "驱动器个数:" & DriveCount
    Call LoadDrivenames(DrivesN)
    For i = 0 To DriveCount - 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 nWidth As 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 As Long)
    Dim OldScaleMode As Integer
    If TypeOf ComboBox_Obj.Parent Is Frame Then Exit Sub
    ' 改变ComboBox控件的容器的坐标度量单位为象素
    OldScaleMode = ComboBox_Obj.Parent.ScaleMode
    ComboBox_Obj.Parent.ScaleMode = vbPixels
    ' 重新定义ComboBox的尺寸
    MoveWindow ComboBox_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 As Long)
    '  NewWidth 是宽度，单位是 pixels
    SendMessage ComboBox_Obj.hwnd, CB_SETDROPPEDWIDTH, NewWidth, 0
End Sub

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

'  改变ComboBox下拉选单长度和宽度
Private Sub Change_But_Click()
    Call SetComboHeight(Combo1, 300)
    Call SetComboWidth(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 As Byte
    bRevision As Byte
    bReserved As Byte
    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
    bFeaturesReg As Byte
    bSectorCountReg As Byte
    bSectorNumberReg As Byte
    bCylLowReg As Byte
    bCylHighReg As Byte
    bDriveHeadReg As Byte
    bCommandReg As Byte
    bReserved As Byte
End Type

Private Type SENDCMDINPARAMS
    cBufferSize As Long
    irDriveRegs As IDEREGS
    bDriveNumber As 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
    bDriverError As Byte
    bIDEStatus As 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
    cBufferSize As Long
    drvStatus As DRIVERSTATUS
    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 As Byte
    wStatusFlags As Integer
    bAttrValue As Byte
    bWorstValue As Byte
    bRawValue(5) As Byte
    bReserved As Byte
End Type

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

Private Type IDSECTOR
    wGenConfig As Integer
    wNumCyls As Integer
    wReserved As Integer
    wNumHeads As Integer
    wBytesPerTrack As Integer
    wBytesPerSector As Integer
    wSectorsPerTrack As Integer
    wVendorUnique(2) As Integer
    sSerialNumber(19) As Byte
    wBufferType As Integer
    wBufferSize As Integer
    wECCSize As Integer
    sFirmwareRev(7) As Byte
    sModelNumber(39) As Byte
    wMoreVendorUnique As Integer
    wDoubleWordIO As Integer
    wCapabilities As Integer
    wReserved1 As Integer
    wPIOTiming As Integer
    wDMATiming As Integer
    wBS As Integer
    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
    dwPlatformId As Long
    szCSDVersion As 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" _
    (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "KERNEL32" _
    (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, _
    ByVal nInBufferSize As Long, lpOutBuffer As Any, _
    ByVal nOutBufferSize As Long, lpBytesReturned As Long, _
    ByVal lpOverlapped As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CloseHandle Lib "KERNEL32" _
    (ByVal hObject As Long) As Long
Private m_DiskInfo As IDSECTOR

Private Function OpenSMART(ByVal nDrive As Byte) As Long

    Dim hSMARTIOCTL As Long
    Dim hd As String
    Dim VersionInfo As OSVERSIONINFO

    hSMARTIOCTL = INVALID_HANDLE_VALUE
    VersionInfo.dwOSVersionInfoSize = Len(VersionInfo)
    GetVersionEx VersionInfo
    Select Case VersionInfo.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
    End Select
    OpenSMART = hSMARTIOCTL

End Function

Private Function DoIDENTIFY(ByVal hSMARTIOCTL As Long, _
    pSCIP As SENDCMDINPARAMS, pSCOP() As Byte, ByVal bIDCmd As Byte, _
    ByVal bDriveNum 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 As SENDCMDINPARAMS, pSCOP As SENDCMDOUTPARAMS, _
    ByVal bDriveNum 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 As Integer)
    Dim i As Integer
    Dim bTemp As Byte

    For i = 0 To uscStrSize - 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 As SENDCMDINPARAMS, _
    ByVal bIDCmd As 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
    Dim hSMARTIOCTL As Long
    Dim cbBytesReturned As Long
    Dim VersionParams As GETVERSIONOUTPARAMS
    Dim scip As SENDCMDINPARAMS
    Dim scop() As Byte
    Dim OutCmd As SENDCMDOUTPARAMS
    Dim bDfpDriveMap As Byte
    Dim bIDCmd As Byte
    Dim uDisk As IDSECTOR

    m_DiskInfo = uDisk
   
    hSMARTIOCTL = OpenSMART(nDrive)
    If hSMARTIOCTL <> 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 Error Resume Next
    Dim i As Integer
    For i = 1 To Len(str)
        If Asc(Mid(str, i, 1)) <> 0 Then PurString = PurString & Mid(str, i, 1)
    Next
    PurString = Trim(PurStrin