楼主在哪？
威海下大雪了

系统托盘图标 例2
将下列文件恢复后:form1.picture1中载入一个图标,运行

【Project Code:将下面代码用记事本保存为 工程1.vbp(VB工程文件),此括弧及括弧内容除外】
Type=Exe
Class=CTray; CTray.cls
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation
Form=Form1.frm
Startup="Form1"
HelpFile=""
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="xufeng"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
AutoRefresh=1


【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "本例演示托盘图标"
   ClientHeight    =   3090
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   4680
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Picture1 
      Height          =   735
      Left            =   720
      Picture         =   "Form1.frx":000C
      ScaleHeight     =   675
      ScaleWidth      =   915
      TabIndex        =   0
      Top             =   600
      Width           =   975
   End
   Begin VB.Menu tempmenu 
      Caption         =   "托盘菜单"
      Begin VB.Menu m_open 
         Caption         =   "打开        "
         Shortcut        =   ^O
      End
      Begin VB.Menu m_save 
         Caption         =   "保存"
         Shortcut        =   ^S
      End
      Begin VB.Menu m_11 
         Caption         =   "-"
      End
      Begin VB.Menu m_exit 
         Caption         =   "关闭"
         Shortcut        =   ^Q
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim WithEvents Tray As CTray
Attribute Tray.VB_VarHelpID = -1

Private Sub Form_Load()
    '托盘图标
    Set Tray = New CTray
    With Tray
        .TipText = Me.Caption   '提示文本
        .PicBox = Picture1   '一个用于托盘的图标(PictureBox)
    End With
    Tray.ShowIcon   '添加图标在托盘
End Sub

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

Private Sub m_exit_Click()
    Unload Me
End Sub

'以下为托盘图标事件
Private Sub Tray_LButtonDblClick()
    '左键双击
End Sub

Private Sub Tray_LButtonDown()
    '左键按下
End Sub

Private Sub Tray_LButtonUp()
    '左键放开
End Sub

Private Sub Tray_RButtonDblClick()
    '右键双击
End Sub

Private Sub Tray_RButtonDown()
    '右键按下
End Sub

Private Sub Tray_RButtonUp()
    '右键放开
    PopupMenu tempmenu
End Sub


【Class Code:将下面代码用记事本保存为 CTray.cls(类模块文件),此括弧及括弧内容除外】

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'-------------------------------------------------------------------
'类模块:托盘图标的添加
'-------------------------------------------------------------------

Option Explicit

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _
        (ByVal dwMessage As Long, pNid As NOTIFYICONDATA) As Boolean

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206

Private Type NOTIFYICONDATA
    lSize As Long
    hWnd As Long
    lId As Long
    lFlags As Long
    lCallBackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

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

Public Event RButtonDown()      '鼠标右键按下
Public Event RButtonUp()        '鼠标右键放开
Public Event RButtonDblClick()  '鼠标右键双击
Public Event LButtonDown()      '鼠标左键按下
Public Event LButtonUp()        '鼠标左键放开
Public Event LButtonDblClick()  '鼠标左键双击

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

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

Public Property Let PicBox(ByVal PicBox As PictureBox)
    Set mPic = PicBox
    With mNID
        .hWnd = mPic.hWnd
        .hIcon = mPic
    End With
End Property

Public Property Get TipText() As String
    TipText = mNID.szTip
End Property

Public Property Let TipText(ByVal TipText As String)
    mNID.szTip = TipText & Chr$(0)
    Shell_NotifyIcon NIM_MODIFY, mNID
End Property

Public Function ShowIcon() As Boolean
    If mPic Is Nothing Then
        ShowIcon = False
    Else
        Shell_NotifyIcon NIM_ADD, mNID
        ShowIcon = True
    End If
End Function

Public Sub DeleteIcon()
    Shell_NotifyIcon NIM_DELETE, mNID
End Sub

Private Sub mPic_Change()
    mNID.hIcon = mPic
    Shell_NotifyIcon NIM_MODIFY, mNID
End Sub

Private Sub mPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static bRec As Boolean
    Dim lMsg As Long

    lMsg = X / Screen.TwipsPerPixelX

    If bRec = False Then
        bRec = True
        Select Case lMsg
            Case WM_LBUTTONDBLCLK:
                '左键双击
                RaiseEvent LButtonDblClick
            Case WM_LBUTTONDOWN:
                '左键按下
                RaiseEvent LButtonDown
            Case WM_LBUTTONUP:
                '左键放开
                RaiseEvent LButtonUp
            Case WM_RBUTTONDBLCLK:
                '右键双击
                RaiseEvent RButtonDblClick
            Case WM_RBUTTONDOWN:
                '右键按下
                RaiseEvent RButtonDown
            Case WM_RBUTTONUP:
                '右键放开
                RaiseEvent RButtonUp
        End Select
        bRec = False
    End If
End Sub

Shell 函数的几个示例
'Form Code:

'执行一个可执行文件，返回一个 Variant (Double)，
'如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。

'语法
'Shell(pathname[,windowstyle])

'Shell 函数的语法含有下面这些命名参数:

'部分 描述
'pathname 必要参数。Variant (String)，要执行的程序名，以及任何必需的参数或命令行变量， _
                    可能还包括目录或文件夹，以及驱动器。
'Windowstyle 可选参数。Variant (Integer)，表示在程序运行时窗口的样式。 _
                       如果 windowstyle 省略，则程序是以具有焦点的最小化窗口来执行的。


'windowstyle 命名参数有以下这些值:
'常数 值 描述
'vbHide 0 窗口是隐藏的，并且焦点被传递给隐藏窗口。
'vbNormalFocus 1 窗口拥有焦点，并且恢复到原来的大小与位置。
'vbMinimizedFocus 2 窗口缩小为图符并拥有焦点。
'vbMaximizedFocus 3 窗口最大化并拥有焦点。
'vbNormalNoFocus 4 窗口被恢复到最近一次的大小与位置。当前活动窗口仍为活动窗口。
'vbMinimizeNoFocus 6 窗口缩小为图符。当前活动窗口仍为活动窗口。

Private Sub Command1_Click()
    '如果指定文件夹不存在,则创建
    If Dir("c:\mydos", vbDirectory) = "" Then MkDir "c:\mydos" '在硬盘上新建一个c:\mydos的文件夹。
    '调用指令,复制一批文件到该文件夹下(需具备xcopy.exe)
    Shell "xcopy.exe C:\WINDOWS\Web\Wallpaper\*.* c:\mydos/s/e", vbHide
    '使用浏览器打开该目录
    Shell "explorer.exe " & "c:\mydos", vbNormalFocus
End Sub

Private Sub Command2_Click()
    '把DOS应用程序的屏幕输出写到一个文件中去。
    '例如用下列代码可把DOS命令copy的帮助信息写到一个文件中去。
    Open "c:\test.bat" For Output As #1 '建立批处理文件
    Print #1, "copy/?>c:\copyhelp.txt"
    Print #1, "@exit"
    Close #1
    
    '执行这个批处理文件
    Shell "c:\test.bat", vbHide
    
    '最后一句必须是@exit，不然经Shell调用后的批处理文件无法从内存中退出
End Sub

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



托盘图标 例1
将下列文件恢复后:form1.icon中载入一个图标,运行
【Project Code:将下面代码用记事本保存为 PROJECT1.vbp(VB工程文件),此括弧及括弧内容除外】
Type=Exe
Form=Form1.frm
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation
Module=APIStuff; Apistuff.bas
IconForm="Form1"
Startup="Form1"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Rocky Mountain Computer Consulting, Inc."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
AutoRefresh=1

【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4710
   ClientLeft      =   1635
   ClientTop       =   1830
   ClientWidth     =   7665
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4710
   ScaleWidth      =   7665
   ShowInTaskbar   =   0   'False
   Begin VB.Menu mnuFile 
      Caption         =   "文件"
      Begin VB.Menu mnuFileExit 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu mnuTray 
      Caption         =   "Popup"
      Visible         =   0   'False
      Begin VB.Menu mnuTrayRestore 
         Caption         =   "恢复"
      End
      Begin VB.Menu mnuTrayMove 
         Caption         =   "移动"
      End
      Begin VB.Menu mnuTraySize 
         Caption         =   "大小"
      End
      Begin VB.Menu mnuTrayMinimize 
         Caption         =   "最小化"
      End
      Begin VB.Menu mnuTrayMaximize 
         Caption         =   "最大化"
      End
      Begin VB.Menu mnuTraySep 
         Caption         =   "-"
      End
      Begin VB.Menu mnuTrayClose 
         Caption         =   "关闭"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public LastState As Integer

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&

Private Sub Form_Load()
    If WindowState = vbMinimized Then
        LastState = vbNormal
    Else
        LastState = WindowState
    End If
    AddToTray Me, mnuTray
    SetTrayTip "VB Helper tray icon program"
End Sub

Private Sub Form_Resize()
    Select Case WindowState
        Case vbMinimized
            mnuTrayMaximize.Enabled = True
            mnuTrayMinimize.Enabled = False
            mnuTrayMove.Enabled = False
            mnuTrayRestore.Enabled = True
            mnuTraySize.Enabled = False
        Case vbMaximized
            mnuTrayMaximize.Enabled = False
            mnuTrayMinimize.Enabled = True
            mnuTrayMove.Enabled = False
            mnuTrayRestore.Enabled = True
            mnuTraySize.Enabled = False
        Case vbNormal
            mnuTrayMaximize.Enabled = True
            mnuTrayMinimize.Enabled = True
            mnuTrayMove.Enabled = True
            mnuTrayRestore.Enabled = False
            mnuTraySize.Enabled = True
    End Select

    If WindowState <> vbMinimized Then _
        LastState = WindowState
End Sub

Private Sub Form_Unload(Cancel As Integer)
    RemoveFromTray
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

Private Sub mnuTrayClose_Click()
    Unload Me
End Sub

Private Sub mnuTrayMaximize_Click()
    WindowState = vbMaximized
End Sub

Private Sub mnuTrayMinimize_Click()
    WindowState = vbMinimized
End Sub

Private Sub mnuTrayMove_Click()
    SendMessage hwnd, WM_SYSCOMMAND, SC_MOVE, 0&
End Sub

Private Sub mnuTrayRestore_Click()
    SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, 0&
End Sub

Private Sub mnuTraySize_Click()
    SendMessage hwnd, WM_SYSCOMMAND, SC_SIZE, 0&
End Sub

(待续)

(续)

【Module Code:将下面代码用记事本保存为 *.bas(基本模块文件),此括弧及括弧内容除外】
Attribute VB_Name = "APIStuff"
Option Explicit

Public OldWindowProc As Long
Public TheForm As Form
Public TheMenu As Menu

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
        (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2

Public Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Private TheData As NOTIFYICONDATA

Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, _
                              ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = TRAY_CALLBACK Then
        If lParam = WM_LBUTTONUP Then
            If TheForm.WindowState = vbMinimized Then _
                TheForm.WindowState = TheForm.LastState
            TheForm.SetFocus
            Exit Function
        End If
        If lParam = WM_RBUTTONUP Then
            TheForm.PopupMenu TheMenu
            Exit Function
        End If
    End If
    
    NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)
End Function

Public Sub AddToTray(frm As Form, mnu As Menu)
    Set TheForm = frm
    Set TheMenu = mnu
    
    OldWindowProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
    With TheData
        .uID = 0
        .hwnd = frm.hwnd
        .cbSize = Len(TheData)
        .hIcon = frm.Icon.Handle
        .uFlags = NIF_ICON
        .uCallbackMessage = TRAY_CALLBACK
        .uFlags = .uFlags Or NIF_MESSAGE
        .cbSize = Len(TheData)
    End With
    Shell_NotifyIcon NIM_ADD, TheData
End Sub

Public Sub RemoveFromTray()
    With TheData
        .uFlags = 0
    End With
    Shell_NotifyIcon NIM_DELETE, TheData
    
    SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProc
End Sub

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

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

    With TheData
        .hIcon = pic.Handle
        .uFlags = NIF_ICON
    End With
    Shell_NotifyIcon NIM_MODIFY, TheData
End Sub

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

几个小函数


'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function LenBB(Expression As String) As Integer
    '取得字符串实际字节长度
    LenBB = LenB(StrConv(Expression, vbFromUnicode))
End Function

'-------------------------------------
'获得我的文档路径
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
        (ByVal pIdl As Long, ByVal pszPath As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
        (ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long
Type SHITEMID
    cb As Long
    abID() As Byte
End Type
Type ITEMIDLIST
    mkid As SHITEMID
End Type

Public Function MyDocumentsDir(oForm As Form) As String
    Dim IDL As ITEMIDLIST
    Dim sPath As String * 260
    If SHGetSpecialFolderLocation(oForm.hWnd, 5, IDL) = 0 Then
        If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then
            '返回我的文档路径
           MyDocumentsDir = Left$(sPath, InStr(sPath, vbNullChar) - 1)
        End If
    End If
End Function

'----------------------------------------

'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function RangeDiff(RangeNameA As String, RangeNameB As String) As Integer
    '返回两列间隔数(Excel表中的列)
    Dim a As Integer, b As Integer
    If Len(RangeNameA) = 0 Or Len(RangeNameB) = 0 Then Exit Function
    RangeNameA = UCase(RangeNameA)
    RangeNameB = UCase(RangeNameB)
    If Len(RangeNameA) = 1 Then
        a = Asc(RangeNameA) - 64
    Else
        a = (Asc(Left(RangeNameA, 1)) - 64) * 26 + Asc(Right(RangeNameA, 1)) - 64
    End If
    If Len(RangeNameB) = 1 Then
        b = Asc(RangeNameB) - 64
    Else
        b = (Asc(Left(RangeNameB, 1)) - 64) * 26 + Asc(Right(RangeNameB, 1)) - 64
    End If
    RangeDiff = b - a
End Function

'-----------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function FindRepeat(strChr As String) As String
    '判断字符串是否有重复字符
    Dim i As Integer, j As Integer
    For i = 1 To Len(strChr)
        For j = 1 To Len(strChr)
            If j <> i Then
                If Mid(strChr, i, 1) = Mid(strChr, j, 1) Then
                    FindRepeat = Mid(strChr, i, 1)
                    Exit Function
                End If
            End If
        Next
    Next
End Function
'---------------------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
'配合上面那个LenBB函数使用
Public Function FileNameIs(AllFileDir As String, FileDirIs As String) As String
    '获取文件路径中的 路径部分 和 文件名部分
    '调用:
    'Dim filedir As String
    'Debug.Print "文件名:", FileNameIs("c:\abc.txt", filedir)
    'Debug.Print "路径:", filedir

    If Len(AllFileDir) = 0 Then FileDirIs = "": Exit Function
    
    Dim v As Variant
    Dim i As Integer
    v = Split(AllFileDir, "\")
    i = UBound(v)
    '取得路径
    FileDirIs = Left(AllFileDir, LenBB(AllFileDir) - LenBB(CStr(v(i))) - 1)
    '取得文件名
    FileNameIs = v(i)
End Function

不错 收藏 谢谢~

值得收藏的标准贴！！

'---------------------------------------------------
检查窗口是否激活

Public OldWindowProc As Long

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Const GWL_WNDPROC = (-4)

Const WM_ACTIVATE = &H6
Const WA_ACTIVE = 1
Const WA_CLICKACTIVE = 2
Const WA_INACTIVE = 0

Public Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, _
                              ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = WM_ACTIVATE Then
        If (wParam = WA_ACTIVE Or wParam = WA_CLICKACTIVE) Then
            '活动
            debug.print "活动"
        Else
            '非活动
            debug.print "不活动"
        End If
    End If

    NewWindowProc = CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam)
End Function

'窗体load中加上此代码:
OldWindowProc = SetWindowLong(hWnd, (-4), AddressOf NewWindowProc)


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

用API指定文件夹(对话框)

'Module Code:
Private Type BrowseInfo
     hWndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
        (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidList As Long, ByVal lpBuffer As String) As Long


Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String
    Dim iNull As Integer
    Dim lpIDList As Long
    Dim lResult As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo

    With udtBI
        .hWndOwner = hWndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    lpIDList = SHBrowseForFolder(udtBI)

    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
       lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)

        If iNull Then
            sPath = Left$(sPath, iNull - 1)
        End If
    End If

    BrowseForFolder = sPath
End Function



'Form Code:
Private Sub Command1_Click()
    Dim sDirectoryName As String
    sDirectoryName = BrowseForFolder(Me.hWnd, "请选择目录")
    Debug.Print sDirectoryName
End Sub


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

判定Variant变量值的类型

VarType 常数   
语法: VarType(varname)
可在代码中的任何地方用下列常数代替实际值：

常数 值 描述 
vbEmpty 0 未初始化（缺省值） 
vbNull 1 不含任何有效数据 
vbInteger 2 Integer 
vbLong 3 长整数 
vbSingle 4 单精度浮点数 
vbDouble 5 双精度浮点数 
vbCurrency 6 Currency 
vbDate 7 Date 
vbString 8 String 
vbObject 9 对象 
vbError 10 错误 
vbBoolean 11 布尔 
vbVariant 12 Variant（只用于变体的数组类型） 
vbDataObject 13 数据访问对象 
vbDecimal 14 Decimal 
vbByte 17 Byte 
vbUserDefinedType 36 包含用户定义类型的变量 
vbArray 8192 数组 


TypeName 函数
返回一个 String，提供有关变量的信息。
语法: TypeName(varname)

必要的 varname 参数是一个 Variant，它包含用户定义类型变量之外的任何变量。
TypeName 所返回的字符串可以是下面列举的任何一个字符串：

返回字符串 变量 

<object type> 类型为 objecttype 的对象 
Byte 位值 
Integer 整数 
Long 长整数 
Single 单精度浮点数 
Double 双精度浮点数 
Currency 货币 
Decimal 十进制值 
Date 日期 
String 字符串 
<Boolean> 布尔值:False 或 True
Error 错误值 
Empty 未初始化 
Null 无效数据 
Object 对象 
Unknown 类型未知的对象 
Nothing 不再引用对象的对象变量 

如果 varname 是一个数组，则返回的字符串可以是任何一个后面添加了空括号的可能的返回字符串（或 Variant）。例如，如果 varname 是一个整数数组，则 TypeName 返回 "Integer()"。


--------------------------------------------------------
VB工程组成结构

文件扩展名及描述
.bas 基本模块
.cls 类模块
.ctl 用户控件文件
.ctx 用户控件的二进制文件
.dca 活动的设计器的高速缓存
.ddf 打包和扩展向导CAB信息文件
.dep 打包和展开向导从属文件
.dll 运行中的AvtiveX部件
.dob AvtiveX文档窗体文件
.dox AvtiveX文档二进制窗体文件
.dsr 活动的设计器文件
.dsx 活动的设计器的二进制文件
.dws 部署向导教本文件
.exe 可执行文件或AvtiveX部件
.frm 窗体文件
.frx 二进制窗体文件
.log 加载错误的日志文件
.oca 控件类型库缓存文件
.ocx AvtiveX控件
.pag 属性页文件
.pgx 二进制属性页文件
.res 资源文件
.tlb 远程自动化类型库文件
.vbd AvtiveX文档状态文件
.vbg Visual Basic组工程文件
.vbl 控件许可文件
.vbp Visual Basic工程文件
.vbr 远程自动化注册文件
.vbw Visual Basic工程工作空间文件
.vbz 向导发射文件
.wct WebClass HTML模板

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

"!"感叹号与"."圆点的用法差异

都用在对象的属性等的引用上.

圆点操作符"."用来表示对象的属性和方法,在引用时需要用在对象的名称、圆点和需要的属性和方法.例如引用按钮的Caption属性:Command1.Caption

感叹号"!"常用于一个控件作为一个特性访问的情况下,例如引用另一窗体中的TextBox的Text属性:Form2!Text1.Text,用"!"连接两个控件,且前者是后者的容器.值得注意的是这里如果使用"."替换"!",可以获得同样效果.为了提高代码可读性,用"!"吧.


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

动态数组相关

'介绍如何声明动态数组,以及保留动态数组的内容

'声明动态数组
Dim MyArray() As Integer


Private Sub Form_Load()
    Dim i As Integer
    Dim j As Integer
    j = 5
    '重定数组数维大小
    ReDim MyArray(j)
    Debug.Print "当前数维:", UBound(MyArray)
    
    For i = 0 To j
        '初始化数组
        MyArray(i) = i
        Debug.Print MyArray(i)
    Next
    
    
    '若要再次重定数维大小,而且要保留原有数据
    '那么,用关键字 Preserve,但它只能重定最末维大小
    j = j + 5
    ReDim Preserve MyArray(j)
    Debug.Print "当前数维:", UBound(MyArray)
    
    '查看数据
    For i = j - 5 To j
        MyArray(i) = i
        Debug.Print MyArray(i)
    Next
    
    Debug.Print "全部数据:"
    For i = 0 To j
        Debug.Print MyArray(i)
    Next
End Sub


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

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


Private Sub Form_DblClick()
    '定义对象
    Dim ctl As Control
    '遍历所有控件
    For Each ctl In Me   'For Each ctl In Me.Controls
        '根据类型,改变属性值
        If TypeOf ctl Is TextBox Then
            ctl.Text = "文本框" & ctl.Text
        ElseIf TypeOf ctl Is Label Then
            ctl.Caption = "标签" & ctl.Caption
        ElseIf TypeOf ctl Is CommandButton Then
            ctl.Caption = "按钮" & ctl.Caption
        End If
    Next
End Sub

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

visual basic 坐标系统概述：

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

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

如何创建坐标系统:

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

1、使用系统缺省定义：

在系统缺省状态下，visual basic使用twips坐标系，以’缇’为单位(1缇的长度等于1/1440英寸；1/567厘米;1/20磅)。应当注意的是：这些值指示的是图形对象打印尺寸的大小。而在计算机屏幕上的物理距离则根据监视器的大小及分辨率的变化而变化。

2、选择系统标准刻度定义：

除了缺省的twips坐标系外，用户还可以通过对象的scalemode属性来设置其它的坐标刻度：（共有8种设置），现将这些设置列表如下：

scalemode值 表示 说明

0 user 用户自定义

1 twip 缇，系统缺省设置

2 point 磅，每英寸约为72磅

3 pixel 像素，像素是监视器或打印机分率的最小单位。每英寸里像素的数目由系统设备的分辨率决定。

4 character 字符，打印时，一个字符高 1/6 英寸，宽1/12 英寸

5 inch 英寸，每英寸为2.54厘米

6 millimeter 毫米

7 centimeter 厘米　

在上述设置值中，除了 0 和 3以外，其它所有模式都是打印机所打印的单位长度。例如，某对象长为4个单位，当 scalemode 设为 5 时，打印时就是4英寸长。在程序中设定scalemode值的代码如下：

'设窗体的刻度单位为厘米。

scalemode = 7

'设 picture1 的刻度单位为像素。

picture1.scalemode = 3

3、创建自定义坐标系统：

当scalemode=0时，即为用户自定义模式，可采用设置对象的相应属性，来创建所需的坐标系统,这些属性是：

scaleleft: 设置对象左边距值

scaletop: 设置对象上边距值

scalewidth: 设置对象宽度

scaleheight: 设置对象高度

下面给出如下设置代码：

scaleleft=100

scaletop=100

scalewidth=300

scaleheight=200

picture1.scaleleft=50

picture1.scaletop=50

则所定义的坐标系如下图所示：

scaletop=100

picture1.scaleleft=50

以上代码定义窗体左上角坐标为（100，100），定义窗体内图形对象picture1距窗体左边距离为50，上边距离为50。scalewidth 和 scaleheight 语句定义窗体内部宽度的 1/300 为水平坐标单位；当前窗体内部高度的 1/200 为垂直坐标单位。如果窗体的大小以后被调整，这些单位保持原状。也就是说：scalewidth 和 scaleheight 是按照对象的内部尺寸来定义单位的，并且这些尺寸不包括边框厚度或菜单标题的高度。scalewidth 和 scaleheight 是指对象内的可用空间的大小。它们决定了对象本身的坐标系统。这有别于内部尺寸和外部尺寸（由 width 和 height属性指定）定义，width 和 height 总是按照容器的坐标系统来表示。另外以上刻度属性都可包括分数，也可是负数。如果将 scalewidth 和 scaleheight 属性设置值为负数即改变坐标系统的方向。

4．使用scale方法定义坐标系统：

一个更简洁的改变坐标系统的途径是使用 scale 方法。定义形式如下：

[object.]scale (x1, y1) – (x2, y2)

x1 和 y1 的值，决定了 scaleleft 和 scaletop 属性的设置值。x2-x1的差值和y2-y1的差值，分别决定了 scalewidth 和 scaleheight 属性的设置值。若指定 x1 > x2 或 y1 > y2 的值，与设置 scalewidth 或 scaleheight 为负值的效果相同。例如：设定窗体坐标系统如下：

scale (100, 100)-(200, 200)

该语句定义等同于以下属性设置：

scaletop=100:scaleleft=100:scalewidth=100:scaleheight=100

如何恢复缺省坐标系统：

在定义了其它坐标系后，如果需要将坐标系统恢复为缺省的twips坐标系，可以使用不含参数的scale方法，如语句：

picture1.scale

将图形对象的坐标系统恢复为缺省，其左上角坐标为（0，0）。



---------------------------------------------------------
键码



键码

常数            值           描述 
vbKeyLButton 1 鼠标左键 
vbKeyRButton 2 鼠标右键 
vbKeyCancel 3 CANCEL 键 
vbKeyMButton 4 鼠标中键 
vbKeyBack 8 BACKSPACE 键 
vbKeyTab 9 TAB 键 
vbKeyClear 12 CLEAR 键 
vbKeyReturn 13 ENTER 键 
vbKeyShift 16 SHIFT 键 
vbKeyControl 17 CTRL 键 
vbKeyMenu 18 菜单键 
vbKeyPause 19 PAUSE 键 
vbKeyCapital 20 CAPS LOCK 键 
vbKeyEscape 27 ESC 键 
vbKeySpace 32 SPACEBAR 键 
vbKeyPageUp 33 PAGEUP 键 
vbKeyPageDown 34 PAGEDOWN 键 
vbKeyEnd 35 END 键 
vbKeyHome 36 HOME 键 
vbKeyLeft 37 LEFT ARROW 键 
vbKeyUp 38 UP ARROW 键 
vbKeyRight 39 RIGHT ARROW 键 
vbKeyDown 40 DOWN ARROW 键 
vbKeySelect 41 SELECT 键 
vbKeyPrint 42 PRINT SCREEN 键 
vbKeyExecute 43 EXECUTE 键 
vbKeySnapshot 44 SNAP SHOT 键 
vbKeyInser 45 INS 键 
vbKeyDelete 46 DEL 键 
vbKeyHelp 47 HELP 键 
vbKeyNumlock 144 NUM LOCK 键 


A 键到 Z 键与其 ASCII 码的相应值'A' 到 'Z' 是一致的
常数 值 描述 
vbKeyA 65 A 键 
vbKeyB 66 B 键 
vbKeyC 67 C 键 
vbKeyD 68 D 键 
vbKeyE 69 E 键 
vbKeyF 70 F 键 
vbKeyG 71 G 键 
vbKeyH 72 H 键 
vbKeyI 73 I 键 
vbKeyJ 74 J 键 
vbKeyK 75 K 键 
vbKeyL 76 L 键 
vbKeyM 77 M 键 
vbKeyN 78 N 键 
vbKeyO 79 O 键 
vbKeyP 80 P 键 
vbKeyQ 81 Q 键 
vbKeyR 82 R 键 
vbKeyS 83 S 键 
vbKeyT 84 T 键 
vbKeyU 85 U 键 
vbKeyV 86 V 键 
vbKeyW 87 W 键 
vbKeyX 88 X 键 
vbKeyY 89 Y 键 
vbKeyZ 90 Z 键 


0 键到 9 键与其 ASCII 码的相应值 '0' 到 '9' 是一致的
常数 值 描述 
vbKey0 48 0 键 
vbKey1 49 1 键 
vbKey2 50 2 键 
vbKey3 51 3 键 
vbKey4 52 4 键 
vbKey5 53 5 键 
vbKey6 54 6 键 
vbKey7 55 7 键 
vbKey8 56 8 键 
vbKey9 57 9 键 


数字小键盘上的键
常数 值 描述 
vbKeyNumpad0 96 0 键 
vbKeyNumpad1 97 1 键 
vbKeyNumpad2 98 2 键 
vbKeyNumpad3 99 3 键 
vbKeyNumpad4 100 4 键 
vbKeyNumpad5 101 5 键 
vbKeyNumpad6 102 6 键 
vbKeyNumpad7 103 7 键 
vbKeyNumpad8 104 8 键 
vbKeyNumpad9 105 9 键 
vbKeyMultiply 106 乘号 (*) 键 
vbKeyAdd 107 加号 (+) 键 
vbKeySeparator 108 ENTER 键（在数字小键盘上） 
vbKeySubtract 109 减号 (-) 键 
vbKeyDecimal 110 小数点 (.) 键 
vbKeyDivide 111 除号 (/) 键 


功能键
常数 值 描述 
vbKeyF1 112 F1 键 
vbKeyF2 113 F2 键 
vbKeyF3 114 F3 键 
vbKeyF4 115 F4 键 
vbKeyF5 116 F5 键 
vbKeyF6 117 F6 键 
vbKeyF7 118 F7 键 
vbKeyF8 119 F8 键 
vbKeyF9 120 F9 键 
vbKeyF10 121 F10 键 
vbKeyF11 122 F11 键 
vbKeyF12 123 F12 键 
vbKeyF13 124 F13 键 
vbKeyF14 125 F14 键 
vbKeyF15 126 F15 键 
vbKeyF16 127 F16 键

以下是我的一个安装包的注释内容:
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;下面的注释包含自解压脚本命令

Path=xufengn635 v2.0
SavePath
Setup=xfn6353.exe
Overwrite=1
Title=庆晓资料运算工具 2.0 安装程序
Text
{
《庆晓资料运算工具  ver 2.0 最终用户许可协议》
首先你必须承认：世界上没有烤不熟的地瓜，以表明你与作者就
地瓜一事已达成共识。
其次，(此处略去)
联系作者：旭峰 
E-mail: kxufeng@163.com
}
Shortcut=D, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0"
Shortcut=P, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0"
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
用WinRar制作自释放压缩包,可以同样有安装界面,同样可以创建快捷键,可以有反安装项,仅把需要的几个部件加进去就行了.体积不会很大,适用于一些免费软件.上述安装包仅1.25M,一张软盘就可以带走.在win98-2上(没有装过任何VB类型程序的系统)运行都可以通过.
其中包括的组件及描述:
xfn6353.exe 主程序(form 3个,用户控件 2个,image 若干,picturebox 8个,Label 若干,combobox 若干,timer ...)704k 
MSVBVM60.DLL 运行库(我们用的很多函数和一些基本控件,诸如Mid,UCase,Shell,Left,Right...都在里面) 1.34M
PICCLP32.OCX 因为做了个动画,用到了PictureClip,所以连控件一并打包 81.1k
help.chm 帮助文件 446k
Sound目录 有几个WAV在里面 40k
n635.ico 图标,工程和压缩包都用到(为了减小体积,要把图标文件中不需要的24X,48X,真彩色等图层全部去掉.仅保留16X 256色和32X 256色两层)

要注意的是,有些不能自我注册的Dll或OCX,可以写个BAT文件解压后自动运行执行注册:
regsvr32 abcd.dll
rem regsvr32 /u abcd.dll
@exit

(那个regsvr32.exe要13k大小,第二行被注释掉的是反注册命令)




---------------------------------------------------------------
磁盘序号
'Form Code:
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" _
        (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _
        ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _
        lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
        ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Function GetSerialNumber(strDrive As String) As Long
    Dim SerialNum As Long
    Dim Res As Long
    Dim Temp1 As String
    Dim Temp2 As String
    Temp1 = String$(255, Chr$(0))
    Temp2 = String$(255, Chr$(0))
    Res = GetVolumeInformation(strDrive, Temp1, _
    Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
    GetSerialNumber = SerialNum
End Function
 
Private Sub form_load()
    '使用该函数:
     MsgBox GetSerialNumber("c:\")
    '它将告诉你C驱的磁盘序号。
End Sub


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

获取所有驱动器类型
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Demo_Frm 
   Caption         =   "Demo"
   ClientHeight    =   2670
   ClientLeft      =   3795
   ClientTop       =   1905
   ClientWidth     =   4035
   LinkTopic       =   "Form1"
   ScaleHeight     =   2670
   ScaleWidth      =   4035
   Tag             =   "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(PurString)
End Function

'################################################################################
'窗体代码：
'Private Sub Form_Load()
'    Dim hdinfo As New CDiskInfo
'    hdinfo.GetDiskInfo 0
'    Text1.Text = "生产厂家/型号:" & hdinfo.pModelNumber
'    Text2.Text = "硬盘序列号:" & hdinfo.pSerialNumber
'End Sub

设置显示模式
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3540
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5970
   LinkTopic       =   "Form1"
   ScaleHeight     =   3540
   ScaleWidth      =   5970
   StartUpPosition =   3  '窗口缺省
   Begin VB.ListBox List1 
      Height          =   3300
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   4215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "退出"
      Height          =   375
      Left            =   4560
      TabIndex        =   1
      Top             =   1080
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "设置显示模式"
      Height          =   375
      Left            =   4560
      TabIndex        =   0
      Top             =   360
      Width           =   1335
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _
        (lpDevMode As Any, ByVal dwflags As Long) As Long
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _
        (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Long
Private Declare Function SendMessageByLong& Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Declare Function InvalidateRect Lib "user32" _
        (ByVal hwnd As Long, lprect As Any, ByVal bErase As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

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

'  设备模式结构
Private Type DEVMODE
    dmDeviceName As String * 32
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName(1 To 32) As Byte
    dmLogPixels As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    dmICMMethod As Long          ' Windows 95 only
    dmICMIntent As Long          ' Windows 95 only
    dmMediaType As Long          ' Windows 95 only
    dmDitherType As Long         ' Windows 95 only
    dmReserved1 As Long          ' Windows 95 only
    dmReserved2 As Long          ' Windows 95 only
End Type

Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_DISPLAYFLAGS = &H200000
Const DM_DISPLAYFREQUENCY = &H400000

Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const DISP_CHANGE_FAILED = -1
Const DISP_CHANGE_BADMODE = -2
Const DISP_CHANGE_NOTUPDATED = -3
Const DISP_CHANGE_BADFLAGS = -4
Const DISP_CHANGE_BADPARAM = -5

Const CDS_UPDATEREGISTRY = 1
Const CDS_FORCE As Long = &H80000000
Const CDS_RESET = &H40000000

Const HWND_BROADCAST = &HFFFF&
Const WM_SYSCOLORCHANGE = &H15
Const WM_PALETTECHANGED = &H311
Const WM_DISPLAYCHANGE = &H7E
Const WM_SETTINGCHANGE = &H1A

Dim ModeCube(128) As DEVMODE
Dim lproc As Long

'  列出显示设备支持的显示模式
Sub LoadDisplayMode()
    Dim i As Long
    Dim RS As Long
    Dim AStr As String
  
    i = 0
    ' 遍历所有的显示模式并在List1中显示出来
    Do
        ModeCube(i).dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_DISPLAYFLAGS Or 

DM_DISPLAYFREQUENCY
        ModeCube(i).dmSize = Len(ModeCube(i))
        '获得显示模式并保存到数组中
        RS = EnumDisplaySettings(vbNullString, i, ModeCube(i))
        If RS Then
            AStr = Str$(ModeCube(i).dmPelsWidth) + "*" + Trim$(Str$(ModeCube(i).dmPelsHeight)) + " "
            Select Case ModeCube(i).dmBitsPerPel
                Case 4
                    AStr = AStr + "16色"
                Case 8
                    AStr = AStr + "256色"
                Case 16
                    AStr = AStr + "16位彩色"
                Case 24
                    AStr = AStr + "24位彩色"
                Case 32
                    AStr = AStr + "32位彩色"
                Case Else
                    AStr = AStr + Str$(ModeCube(i).dmBitsPerPel)
            End Select
            AStr = AStr + "  刷新频率:" & CStr(ModeCube(i).dmDisplayFrequency) + "Hz"
            i = i + 1
        End If
        List1.AddItem AStr
    Loop Until (RS = 0)     '获得最后一个显示模式之后EnumDisplaySettings会返回0
End Sub

'  设置显示模式
Private Sub Command1_Click()
    Dim aDev As DEVMODE
    Dim RS As Long
        
    If List1.ListIndex < 0 Then Exit Sub
    aDev = ModeCube(List1.ListIndex)
    
    RS = ChangeDisplaySettings(aDev, CDS_FORCE)
 
    '  改变完显示模式设置之后向所有的窗口发送显示模式改变消息
    RS = SendMessageByLong(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0&, 0&)
    RS = SendMessageByLong(HWND_BROADCAST, WM_PALETTECHANGED, Me.hwnd, 0&)
    RS = PostMessage(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0&, 0&)
    
    '  windows就会重画窗口
    RS = InvalidateRect(0&, ByVal 0, 1&)
End Sub

'  加载窗体时加载显示系统支持的显示模式
Private Sub Form_Load()
    LoadDisplayMode
End Sub


------------------------------------------
使ComboBox自动下拉

Option Explicit

'使ComboBox自动下拉
Const CB_SHOWDROPDOWN = &H14F
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 Sub Combo1_Click()
    Text1.Text = Combo1.Text
End Sub

Private Sub Combo1_GotFocus()
    '获得焦点自动拉开
    SendMessage Combo1.hWnd, CB_SHOWDROPDOWN, 1, ByVal 0&
End Sub

Private Sub Form_Load()
    Dim i As Integer
    For i = 0 To 10
        Combo1.AddItem "项目" & i
    Next
End Sub

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

动态添加控件

Option Explicit

Private WithEvents NewButton As CommandButton

Private Sub Command1_Click()
    If NewButton Is Nothing Then
        Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Me)
        NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top
        NewButton.Caption = "新按钮"
        NewButton.Visible = True
    End If
End Sub

Private Sub NewButton_Click()
    MsgBox "你单击了" & NewButton.Caption
End Sub


-----------------------------------------------------
'取得控件绝对Top值(left值也类似)
            
Public Function AbsoluteTop(ctlContl As Control) As Single
    Dim wrkContl As Control
    Dim wrkTopPos As Single
    '
    On Error GoTo AbsoluteTopError
    ' 初始
    Set wrkContl = ctlContl
    wrkTopPos = 0
    ' 循环
    Do
        If (wrkContl.Container.Name = ctlContl.Parent.Name) Then Exit Do
        wrkTopPos = wrkTopPos + wrkContl.Top ' 计算位置
        Set wrkContl = wrkContl.Container ' 下个控件
    Loop
    
    AbsoluteTop = wrkTopPos + ctlContl.Parent.Top
    Exit Function
    '
AbsoluteTopError:
    AbsoluteTop = ctlContl.Top + ctlContl.Parent.Top
End Function

顶下

SendMessage函数
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5700
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   6735
   LinkTopic       =   "Form1"
   ScaleHeight     =   5700
   ScaleWidth      =   6735
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox Text2 
      Height          =   375
      Left            =   1320
      TabIndex        =   14
      Top             =   2880
      Width           =   1215
   End
   Begin VB.ListBox List1 
      Height          =   1860
      Left            =   1320
      TabIndex        =   13
      Top             =   3360
      Width           =   1215
   End
   Begin VB.CommandButton Command4 
      Caption         =   "添加项目和滚动条"
      Height          =   495
      Left            =   3120
      TabIndex        =   11
      Top             =   3480
      Width           =   1935
   End
   Begin VB.CommandButton Command3 
      Caption         =   "收起"
      Height          =   495
      Left            =   4320
      TabIndex        =   10
      Top             =   2040
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "拉开"
      Height          =   495
      Left            =   3000
      TabIndex        =   9
      Top             =   2040
      Width           =   1215
   End
   Begin VB.ComboBox Combo1 
      Height          =   300
      Left            =   960
      TabIndex        =   8
      Text            =   "Combo1"
      Top             =   2040
      Width           =   1935
   End
   Begin VB.CommandButton Command1 
      Caption         =   "统计"
      Height          =   495
      Left            =   5040
      TabIndex        =   6
      Top             =   240
      Width           =   1215
   End
   Begin VB.TextBox TxtString 
      Height          =   495
      Left            =   2880
      TabIndex        =   2
      Top             =   960
      Width           =   1815
   End
   Begin VB.TextBox txtLineCount 
      Height          =   375
      Left            =   3600
      TabIndex        =   1
      Top             =   120
      Width           =   1095
   End
   Begin VB.TextBox Text1 
      Height          =   1335
      Left            =   960
      MultiLine       =   -1  'True
      TabIndex        =   0
      Top             =   120
      Width           =   1575
   End
   Begin VB.Label Label4 
      Caption         =   "例三 例四"
      Height          =   255
      Index           =   1
      Left            =   120
      TabIndex        =   12
      Top             =   2880
      Width           =   1095
   End
   Begin VB.Label Label4 
      Caption         =   "例二"
      Height          =   255
      Index           =   0
      Left            =   120
      TabIndex        =   7
      Top             =   2040
      Width           =   735
   End
   Begin VB.Label Label3 
      Caption         =   "例一"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   495
   End
   Begin VB.Label Label2 
      Caption         =   "第三行字符:"
      Height          =   255
      Left            =   2880
      TabIndex        =   4
      Top             =   720
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "总行数:"
      Height          =   255
      Left            =   2880
      TabIndex        =   3
      Top             =   240
      Width           =   735
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'SendMessage函数在VB中的函数说明如下:
'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
'其中四个自变量的含义和说明如下:
'hWnd：对象的句柄。希望将消息传送给哪个对象，就把该对象的句柄作为实参传送，
    '在VB中可以简单地用“对象.hWnd”获得某个对象的句柄，
    '如Text1.hWnd和Form1.hWnd分别可以得到Text1和Form1的句柄。
'wMsg：被发送的消息。根据具体需求和不同的对象，将不同的消息作为实参传送，以产生预期的动作。
'wParam、lParam：附加的消息信息。这两个是可选的参数，用来提供关于wMsg消息更多的信息，
    '不同的wMsg可能使用这两个参数中的0、1或2个，如果不需要哪个附加参数，则将实参赋为NULL（在VB中赋为0）。



'例1 多行TextBox中的快速处理功能在处理多行TextBox时我们经常会碰到以下几种情况:
   '希望了解多行TextBox中目前共有多少行文字?
   '想快速返回第N行的文字?
   '对于上面的情况，如果用VB自身的语句或函数来实现的话，要写不短的代码，
   '而且由于要采用顺序查找的办法来完成，因此代码的执行效率也很低。
   '如果使用SendMessage函数则可以大大减少代码量，并大幅度的提高执行效率。
   '用SendMessage函数完成上面两个任务的方法非常简单，每个任务只需简单地发送一条消息给多行TextBox即可，
   '两个消息分别为：EM_GETLINECOUNT、EM_GETLINE，其它参数和返回值见附表。
'新建工程，在Form1上添加三个TextBox（名称分别为Text1、txtLineCount、TxtString，
'将Text1的MultiLine属性置为True）、三个标签和一个命令按钮。
'为工程添加一个模块Moudle1，在其中写如下声明（其中
'SendMessage函数的声明可以从VB的“API浏览器”中复制）： 消息常量名 消息值 wParam lParam 返回值
'EM_GETLINECOUNT &HBA 未用 未用 行数
'EM_GETLINE &HC4 要找的行号 存结果的字节串 结果字节串的字节数

'两点补充说明：在调用SendMessage获取第N行字符串时，lParam需要说明为字节数组，
'在调用完成后，再将字节数组转换为字符串；
'另外，调用前必须在lParam的前两个字节指明允许存放的最大长度，
'其中第一个字节为低位，第二个字节为高位，本例将高位（即str(1)）置1．说明最大允许存放256个字符。

Private Sub Command1_Click()
    Dim str(256) As Byte
    str(1) = 1 '最大允许存放256个字符
    '获取总行数，结果显示在文本框txtLineCount中
    txtLineCount = SendMessage(Text1.hwnd, EM_GETLINECOUNT, 0, 0)
    '获取第3行的数据放在str中，转换为字符串后显示在文本框txtString中
    SendMessage Text1.hwnd, EM_GETLINE, 2, str(0)
    TxtString = StrConv(str, vbUnicode)
End Sub

'例2 程序控制拉下或收起组合框的下拉列来
   '一般情况下，为了拉下或收起组合框的下拉列表，需要用键盘或鼠标进行操作，
   '而有时我们希望程序运行的某个时刻自动拉出下拉列表（比如在一些演示程序中），
   '为了实现这个目的，我们也只有借助于SendMessage函数，方法是发一个CB_SHOWDROPDOWN(&H14F)消息给组合框。
   '在发CB_SHOWDROPDOWN消息时，wParam参数决定了是拉下列表（=True时）还是收起列表（＝False时），
   'lParam无用（设为0）。


Private Sub Form_Load()
    Dim i As Integer
    For i = 0 To 10
        Combo1.AddItem "项目" & i
    Next
End Sub

Private Sub Command2_Click()
    '当程序中某处需要拉下组合框Combol的列表时，写如下调用语句：
    SendMessage Combo1.hwnd, CB_SHOWDROPDOWN, True, str(0)
End Sub

Private Sub Command3_Click()
    '当需要收起组合框Combol的列表时，写如下语句：
    SendMessage Combol.hwnd, CB_SHOWDROPDOWN, False, str(0)
End Sub


'例3 在列表框中查找匹配的项目
   '在Win95风格的帮助系统中一般都有一个“索引”页，索引页含有一个文本框和一个列表框，
   '当用户在文本框中输入文字时，下拉列表会动态地显示与文本框中文字最匹配的项目，
   '为用户提供了最大的方便。
   '这种效果在应用程序的帮助系统中很容易实现（只要按照Win95帮助系统的正常制作过程制作就可以实现），
   '如果想在应用程序的其它地方实现这种特性就需费一番心思了。
   '而使用SendMessage函数实现上述特性则非常简单，甚至只需一条语句就足够了，
   '那就是在文本框的Change事件中给列表框发一条LB_FINDSTRING(&H18F）消息，
   '该消息告诉列表框在列表中查找匹配的项目。
   '在发LB_FINDSTRING消息时，wParam参数代表从列表框的哪一个项目后面开始查找，
   '一般情况下该参数可定为-1，表示从List1(0)即第一项开始向后循环查找，
   'lParam则传进欲搜索的字符串（必须采用值传递）。
   '具体的代码和运行画面与后面的例4合并在一起演示
'例4 为ListBox添加水平滚动条
   '在VB中，列表框控件仅提供垂直滚动条，没有设置水平滚动条的能力，当某些项目的文本宽度较长时，
   '超出列表框宽度部分的文本就无法显示出来，因此，很有必要为ListBox添加一个水平滚动条来方便操作。
   '为添加水平滚动条，只需发一条LB_SETHORIZONTALEXTENT(&H194)消息给列表框即可。
   '发送消息时，wParam为滚动条的长度（以像素为单位，可通过计算得出准确的长度，
   '也可随便给一个大于最大文本宽度的数字，如本例的250），lParam无用。
   '下面是例3和例4合并在一起的代码和运行画面


Private Sub Command4_Click()
    List1.AddItem "软件"
    List1.AddItem "电脑游戏"
    List1.AddItem "电视机"
    List1.AddItem "电视台"
    List1.AddItem "电脑"
    List1.AddItem "电脑游戏软件"
    '下一句为列表框添加水平滚动条
    SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, 250, 0
End Sub

Private Sub Text2_Change()
    '注意！当lParam传入的是字符串时，必须用ByVal传递
    List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal Text2.Text)
End Sub

'事实上利用该函数我们还可以完成更多更好的任务，
'如控制文本框的自动滚屏、实现文字编辑过程中的Undo功能、操纵应用程序的窗体控制菜单等等
 

【Module Code:将下面代码用记事本保存为 *.bas(基本模块文件),此括弧及括弧内容除外】
Attribute VB_Name = "Module1"
'例1
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const EM_GETLINECOUNT = &HBA
Public Const EM_GETLINE = &HC4

'例2
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const CB_SHOWDROPDOWN = &H14F

'例3 例4
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const LB_FINDSTRING = &H18F
Public Const LB_SETHORIZONTALEXTENT = &H194

'使窗口不接受键盘输入及Mouse Click
'就好比呼叫MsgBox之後，Form就不接受Mouse Click与KeyPress，但是Form仍可处於Activate的状态，
'即我们暂停了Mouse Click,KeyPress，等待我们要做事都做完了，再将之回复。
'不过Mouse仍可自由的移动，若要让Mouse也不能动，就使用JournalPlayBack Hook，而不是使用本方法。

'EnableWindow()可达目的，第二个参数传0进入则不能输入，传1则相反


Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
    '封闭
    Call EnableWindow(Me.hwnd, 0)
    Me.Caption = "现在拒绝KeyPress, MouseClick"
    
    '限时后解开
    Dim i As Long
    For i = 1 To 100
        Call Sleep(100)
        DoEvents '虽有DoEvents，会发现，按Form的任何地方都没有反应
    Next i
    
    
    Me.Caption = "现在解除了"
    Call EnableWindow(Me.hwnd, 1)
End Sub

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

半透明窗体

Option Explicit

Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, _
        ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2

Private Sub Command1_Click()
    '关闭
    Timer4.Interval = 50
End Sub

Private Sub Form_Load()
    Dim FormStyle As Long
     
    '取的窗口原先的样式
    FormStyle = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
    '使窗体添加上新的样式WS_EX_LAYERED
    FormStyle = FormStyle Or WS_EX_LAYERED
    '把新的样式赋给窗体
    SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    
    '直接设置一个值(0-255之间)替换数值255来改变透明度,这里用180
    SetLayeredWindowAttributes Me.hwnd, 0, 180, LWA_ALPHA    
End Sub

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

去掉关闭按钮 - 例子

'Module Code:
Option Explicit
'第一种方法
Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function DeleteMenu Lib "User32" _
        (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Public Const MF_BYPOSITION = &H400&

'第二种方法
'Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function RemoveMenu Lib "User32" _
        (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
'Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
'Public Const MF_BYPOSITION = &H400&
Public Const MF_DISABLED = &H2&

'第一种方法
Public Sub DisableX(Frm As Form)
    Dim hMenu As Long, nCount As Long
    hMenu = GetSystemMenu(Frm.hwnd, 0)
    nCount = GetMenuItemCount(hMenu)
    Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION)
    DrawMenuBar Frm.hwnd
End Sub



'Form Code:
Option Explicit

Private Sub Form_Load()
'第一种方法
    Dim hwndMenu As Long
    Dim c As Long
    hwndMenu = GetSystemMenu(Me.hwnd, 0)
    
    c = GetMenuItemCount(hwndMenu)
    
    DeleteMenu hwndMenu, c - 1, MF_BYPOSITION
    
    c = GetMenuItemCount(hwndMenu)
    DeleteMenu hwndMenu, c - 1, MF_BYPOSITION
    
'第二种方法
    'Call DisableX(Me)
End Sub

Private Sub Command1_Click()
    End
End Sub

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

运行时改变BorderStyle属性值

Option Explicit

Private Const GWL_STYLE As Long = (-16&)
Private Const GWL_EXSTYLE As Long = (-20&)
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000

Private Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hWnd&, ByVal nIndex&)
Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" _
        (ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&)
    
Private Type POINTAPI
    x As Long
    y As Long
End Type
    
Private Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI)
Private Declare Function SetCursorPos& Lib "user32" (ByVal x&, ByVal y&)
Private Declare Function ClientToScreen& Lib "user32" (ByVal hWnd&, lpPoint As POINTAPI)
Private Declare Function GetSystemMenu& Lib "user32" (ByVal hWnd&, ByVal bRevert&)

Private Sub Command1_Click()
    Call SetWindowLong(hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) Xor _
                      (WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX))
    
    Call GetSystemMenu(hWnd, 1&)
    
    Move Left, Top, Width - 50, Height - 50
    Move Left, Top, Width + 50, Height + 50
          
    Dim tagSavePoint As POINTAPI, tagMovePoint As POINTAPI
    
    Call GetCursorPos(tagSavePoint)
          
    With tagMovePoint
        .x = (-1)
        .y = 10
    End With
    
    Call ClientToScreen(hWnd, tagMovePoint)
    Call SetCursorPos(tagMovePoint.x, tagMovePoint.y)
    Call SetCursorPos(tagSavePoint.x, tagSavePoint.y)
End Sub



--------------------------------------------------------------------------
最小化所有窗口

'Module Code:
Option Explicit

Public Declare Function EnumWindows Lib "user32" _
        (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function ShowWindow Lib "user32" _
        (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
   
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_VISIBLE = &H10000000
Public Const GWL_STYLE = (-16)
Public Const SW_MINIMIZE = 6
   
'该函数是EnumWindows的回调函数，EnumWindows函数将遍历的窗口句柄传递到hwnd参数中
Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Long
    Dim l As Long
    Dim ld As Long
    
    ld = GetWindowLong(hwnd, GWL_STYLE)
    '如果窗口具有最小化按钮并且窗口是可见的就将该窗口最小化
    If ((ld And WS_MINIMIZEBOX) = WS_MINIMIZEBOX) Then
        If ((ld And WS_VISIBLE)) Then
            If ShowWindow(hwnd, SW_MINIMIZE) Then
            End If
        End If
    End If
    EnumWindowsProc = True
End Function


'form code
Private Sub Command1_Click()
    Dim l As Long
    
    '遍历所有的窗口
    l = EnumWindows(AddressOf EnumWindowsProc, 0)
End Sub


------------------------------------------------------------------------
动态光标

Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
        (ByVal lpFileName As String) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Const GCL_HCURSOR = (-12)
Dim mhBaseCursor As Long
Dim mhAniCursor As Long

Private Sub Form_Load()
    '保存缺省的光标
    mhBaseCursor = GetClassLong(Me.hwnd, GCL_HCURSOR)
    '装载动态光标文件
    mhAniCursor = LoadCursorFromFile("horse.ani")
    '设置窗体光标为动态光标
    SetClassLong Me.hwnd, GCL_HCURSOR, mhAniCursor
End Sub

'恢复缺省光标，并删除动画光标
Private Sub Form_Unload(Cancel As Integer)
    SetClassLong Me.hwnd, GCL_HCURSOR, mhBaseCursor
    DestroyCursor (mhAniCursor)
End Sub

指挥光标移动和按键

【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form FrmMouse 
   Caption         =   "鼠标控制"
   ClientHeight    =   3690
   ClientLeft      =   645
   ClientTop       =   2700
   ClientWidth     =   4095
   HasDC           =   0   'False
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   3690
   ScaleWidth      =   4095
   Begin VB.CommandButton TestCmd 
      Caption         =   "TestCmd"
      Height          =   375
      Left            =   840
      TabIndex        =   2
      Top             =   240
      Width           =   1215
   End
   Begin VB.CommandButton DemoCmd 
      Caption         =   "演示"
      Height          =   420
      Left            =   2280
      TabIndex        =   0
      Top             =   3240
      Width           =   1740
   End
   Begin VB.Shape cmdDemo 
      Height          =   3075
      Left            =   75
      Top             =   45
      Width           =   3915
   End
   Begin VB.Label lblTip 
      AutoSize        =   -1  'True
      Caption         =   "提示"
      Height          =   180
      Left            =   225
      TabIndex        =   1
      Top             =   3330
      Width           =   480
   End
End
Attribute VB_Name = "FrmMouse"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const MK_CONTROL = &H8  ' 键盘Ctrl键
Private Const MK_LBUTTON = &H1  ' 鼠标左键
Private Const MK_MBUTTON = &H10 ' 鼠标中键
Private Const MK_RBUTTON = &H2  ' 鼠标右键

Private Const WM_MBUTTONDOWN = &H207   ' 鼠标中键按下
Private Const WM_MBUTTONUP = &H208     ' 鼠标中键抬起
Private Const WM_LBUTTONDOWN = &H201   ' 鼠标左键按下
Private Const WM_LBUTTONUP = &H202     ' 鼠标左键抬起
Private Const WM_LBUTTONDBLCLK = &H203 ' 鼠标左键双击
Private Const WM_MOUSEMOVE = &H200     ' 鼠标移动
Private Const WM_RBUTTONDBLCLK = &H206 ' 鼠标右键双击
Private Const WM_RBUTTONDOWN = &H204   ' 鼠标右键按下
Private Const WM_RBUTTONUP = &H205     ' 鼠标右键抬起
Private Const HWND_BROADCAST = &HFFFF& ' 用来对所有的窗口传送消息

Private Type POINTAPI
    X As Long
    Y As Long
End Type

' 根据lParam 参数取得对应的X,Y坐标
Private Function GetPointXY(ByVal lParam As Long) As POINTAPI
    GetPointXY.X = lParam And &HFFFF
    GetPointXY.Y = (lParam And &HFFFF0000) / (2 ^ 16)
End Function

' 将位置坐标转换为 Twips单位
Private Function XY2Twips(ByRef pos As POINTAPI)
    pos.X = pos.X * Screen.TwipsPerPixelX
    pos.Y = pos.Y * Screen.TwipsPerPixelY
End Function

' 移动光标
Private Sub MoveCursor(ByVal X As Integer, ByVal Y As Integer)
    SetCursorPos X, Y
    Me.Caption = "X:" & X & ",Y:" & Y
End Sub

' 延时
Public Sub Pause(HowLong As Long)
    Dim tick As Long
    
    tick = GetTickCount()
    Do
      DoEvents
    Loop Until tick + HowLong < GetTickCount
End Sub

'  移动光标
Private Sub MouseMove()
    Dim X As Long, Y As Long
    Dim pos As POINTAPI
    Dim demopos As POINTAPI
    
    ' 演示按钮区域的左上角
    demopos.X = (TestCmd.Left + TestCmd.Width / 2 + Me.Left) / Screen.TwipsPerPixelX
    demopos.Y = (TestCmd.Top + TestCmd.Height / 2 + Me.Top + 300) / Screen.TwipsPerPixelY
    
    ' 得到当前光标位置
    GetCursorPos pos
    
    ' 循环，将光标移动到 demopos 位置
    For X = pos.X To demopos.X Step -1
        Pause 4
        MoveCursor X, pos.Y
    Next
    For Y = pos.Y To demopos.Y Step -1
        Pause 10
        MoveCursor demopos.X, Y
    Next
End Sub

'  单击演示按钮开始演示
Private Sub DemoCmd_Click()
    Dim lParam As Long
    Dim pos As POINTAPI
    Dim i As Integer
    Dim h As Long
    
    '  移动光标
    Call MouseMove
    
    '  得到当前光标位置
    GetCursorPos pos
    lParam = CLng(pos.X) + CLng(pos.Y) * (2 ^ 16)
    h = TestCmd.hwnd
    '  传递鼠标按下操作
    Call PostMessage(h, WM_LBUTTONDOWN, MK_LBUTTON, lParam)
    lblTip.Caption = "光标按下"
    DoEvents
    '  延时
    Pause 1000
    '  传递鼠标抬起操作
    Call PostMessage(Me.TestCmd.hwnd, WM_LBUTTONUP, MK_LBUTTON, lParam)
    Me.lblTip.Caption = "光标抬起"
End Sub
 
Private Sub TestCmd_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MsgBox "HELLO"
End Sub

关机消息的拦截

'模块代码
Option Explicit
   
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) 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
   
Public Const GWL_WNDPROC = (-4)
Public Const WM_ENDSESSION = &H16
Public Const WM_QUERYENDSESSION = &H11
   
Public preWinProc As Long
   
Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = WM_QUERYENDSESSION Then
        Debug.Print "QryEnd", wParam, lParam
    Else
        If Msg = WM_ENDSESSION Then
            If wParam = 0 Then '代表将顺利关机或LogOff，这时便得做正常结束程序的操作
                '实际下面这些代码不会被执行,为了测试结果,先写上
                Open "c:\ttt.txt" For Output As #1
                Print #1, "正常关闭程序" & vbCrLf
                Close #1
            Else    'wParam = 1
                Open "c:\ttt.txt" For Output As #1
                Print #1, "非正常关闭程序. wParam = " & wParam & vbCrLf & "关机时间:" & Now & vbCrLf
                Close #1
            End If
        End If
    End If
    
    '将之送往原来的Window Procedure
    wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function


'关机消息的拦截

'在关机或Logff前信息的拦截

'如果我们关机或Logoff时，我们的程序有时会因而无法按正常程序结束，一般我们会在Form的Unload中一段程序结束时
'要做什么事，但是，如果使用者直接用开始功能菜单的关机，会使UnLoad的部份没有做到，
'我们现在就想办法来拦截关机(或Logoff)时的信息?

'一般来说，关机或Logff后，Windows会传依序送出WM_QUERYENDSESSION的信息给每个Process，
'如果中间有一个Process不能顺利结束(例如：Word修改后未存档，而出现是否存档，但我们按取消)，
'这时该信息执行的结果会传回False(0)，这时Windows也就不再继续送WM_QUERYENDSESSION给下一个Proccess。
'反之，如果所有的Process都可以顺利结束(也就是每个送出的WM_QUERYENDSESSION都传回True)，
'那才代表可以顺利结束。

'不管WM_QUERYENDSESSION最后的结果是可以顺利结束或不能顺利结束，
'Windows会再送一个WM_ENDSESSION的信息给所有的Process，
'而wParam的内容便是指出是否可以顺利结束(True菜单可以，False菜单不行，
'在vb中则Check wParam = 0 菜单False，1菜单True)，说到这里大概就知道该如何做啦，程序如下：

'窗体代码
Private Sub Form_Load()
    Dim ret As Long
    
    '记录原来的Window Procedure的位址
    preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
    '设定form的window Procedure到wndproc
    ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
End Sub
   
Private Sub Form_Unload(Cancel As Integer)
    Dim ret As Long
    Dim fno As Long
    
    '取消Message的截取，而使之又只送往原来的Window Procedure
    ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
    
    '这里只是要看看用关机的方式结束程序时，会不会执行到这里
    '退出程序时,会建立这个文件,并写入一段内容
    fno = FreeFile
    Open "c:\tt2.txt" For Append As fno
    Print #fno, "ccc1" & vbCrLf & Now
    Close #fno
End Sub


------------------------------------------------
'利用API实现清除文档名

'范例
'其中uFlags如为1,pv则为一路径字符串的地址;如为2,则为项标示列表的地址。
Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String)

Private Sub Command1_Click()
    Call SHAddToRecentDocs(2, vbNullString)
End Sub

'如果程序设计需要往"文档"菜单中添加文件,只需把vbNullString改为文件的路径,如“c:\windows\a.txt"

vb实现多线程！    S.F.（原作） 
昨晚2:30的时候还没睡着，觉得有必要把vb编写多线程程序再次写一次；主要是以前忽略
的细节和重要的环节；今天在公司打开一年多没用的vb，写了如下的代码；想写多线程
的朋友可以调试一下看看，关于多线程的任务模式，同步和互斥，临界资源和临界区
（文中提到）欢迎跟帖讨论； 
'请将该部分数据保存为 FORM1.frm 文件 
VERSION 5.00 
Begin VB.Form Form1 
  Caption       =   "多线程" 
   ClientHeight    = 3195 
   ClientLeft      =   60 
   ClientTop      = 345 
   ClientWidth     = 6450 
   LinkTopic      =   "Form1" 
   ScaleHeight     = 3195 
   ScaleWidth      = 6450 
   StartUpPosition =   3  '窗口缺省 
   Begin VB.TextBox Text1 
    Height        = 270 
  Left        = 960 
      TabIndex     = 2 
  Text        = "2" 
  Top        = 2760 
   Width        = 2415 
  End 
   Begin VB.CommandButton Command2 
     Caption       =   "返回" 
    Height        = 255 
  Left        = 3480 
      TabIndex     = 1 
  Top        = 2760 
   Width        = 1455 
  End 
   Begin VB.CommandButton Command1 
     Caption       =   "Start Count" 
    Height        = 255 
  Left        = 3480 
      TabIndex     = 0 
  Top        = 240 
   Width        = 1455 
  End 
   Begin VB.Label Label1 
      AutoSize    =   -1 'True 
     Caption       =   "主线程执行结果测试:" 
    Height        = 180 
  Left        = 600 
      TabIndex     = 3 
  Top        = 2400 
   Width        = 1710 
   End 
End 
Attribute VB_Name = "Form1" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = False 
Attribute VB_PredeclaredId = True 
Attribute VB_Exposed = False  

'下载地址:http://www.bssoft.com.cn/vbThread.rar 

Private Sub Command1_Click() 
'声明了线程ID 
    Dim threadid1 As Long 
    Dim threadid2 As Long 

'参数一，lpThreadAttributes 线程安全属性，传递为NULL 
'参数二，dwStackSize ，线程堆栈大小，可以为0，表示堆栈和此应用堆栈相同 
'参数三，lpstartAddress ，执行函数地址，用AddressOf 获取 
'参数四，lpParameter ，执行函数的参数地址，可以是一个记录或者是别的类型，用VarPtr获取参数地址（varptr为未公开函数）！！ 
'参数五，dwCreationFlags ，表示线程创建后的状态！，0表示立即运行，create_SUSPENDED表示线程挂起 
'参数六，lpThreadID 表示分配给线程的线程号 
    Call CreateThread(Null, ByVal O&, AddressOf Module1.OutText1, VarPtr(0), ByVal 0&, threadid1) 
    Call CreateThread(Null, ByVal 0&, AddressOf Module1.OutText2, VarPtr(0), ByVal 0&, threadid2) 
    
End Sub 

Private Sub Command2_Click() 
'该事件运行于主线程！ 
    Dim i As Long 
    i = CLng(Text1.Text) 
    Text1.Text = CStr(i * i)  '不要点击次数太多，LONG 类型会溢出 
End Sub 

Private Sub Form_Load() 
'保存窗体句柄全局变量，用于在form 上绘图 
    formhandle = Form1.hwnd 
End Sub 



'请将该部分数据保存为 Module1.bas 文件 
Attribute VB_Name = "Module1" 

'线程安全属性数据结构； 
Public Type SECURITY_ATTRIBUTES 
       nLength As Long 
        lpSecurityDescriptor As Long 
        bInheritHandle As Long 
End Type 

'这个是用于多线程访问临界资源同步Api的数据结构 
Public Type CRITICAL_SECTION 
    dummy As Long 
End Type 
'为什么用GDI 函数绘图？原因等下再讲 
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long 
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long 
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long 
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long 
'请注意；createThread APi声明已被我修改过，修改的地方请自行参照APIView复制的内容 
Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long 
'这个是sleep,作用就是让两个线程绘图频率不一致，效果才明显。 
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
Public Declare Sub EnterCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)  '进入临界区 
Public Declare Sub LeaveCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)  '离开临界区 

'几个重要的函数举例 
'ObjPtr：返回对象实例私有域的地址。 
'StrPtr：返回字符串第一个字的地址。 
'VarPtr：返回变量的地址。 

'全局的form的句柄！ 
Public formhandle As Long 
'临界数据结构 
Public sect As CRITICAL_SECTION 

Sub OutText1()  '过程一 
Dim i As Long 
Dim dc As Long 
Dim s As String 
    dc = GetDC(formhandle) '获取窗体句柄的DC 
   For i = 1 To 100000 
        s = CStr(i) 
        Call SetBkColor(dc, &HF0F0F0)  '设置绘制区域的背景色，也起清除作用 
        Call TextOut(dc, 10, 10, s, Len(s)) '输出文本！ 
        Call Sleep(40) '等待 
  Next 
    Call ReleaseDC(formhandle, dc)  '释放资源！ 
   ' Call EnterCriticalSection(sect) 
   ' 上下表示该处为临界区，如果要对工程全局变量做操作，最好在该区域内 
   ' 否则线程同步过程中，非常容易让程序崩溃 
   ' Call LeaveCriticalSection(sect) 
End Sub 

Sub OutText2()  '和过程一类似 
Dim i As Long 
Dim dc As Long 
Dim s As String 
    dc = GetDC(formhandle) 
   For i = 1 To 100000 
        s = CStr(i) 
        Call SetBkColor(dc, &HF0F0F0) 
        Call TextOut(dc, 10, 80, s, Len(s))  '文本位置改变了 
        Call Sleep(20) '延时改变了 
  Next 
    Call ReleaseDC(formhandle, dc) 
   ' Call EnterCriticalSection(sect) 
  '  Call LeaveCriticalSection(sect) 
End Sub 


'关于为何使用gdi 函数输出文本，这是一个很重要的内容； 
'程序在记数时用了难用的TextOut 函数，而没有使用标签控件，这是因为 
'vb的组件不都是线程安全的，当多线程访问不是线程安全的组件，那么会 
'产生严重错误。 

'mailto:chinasf@Hotmail.com 
'作者：萧寒(410000)

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

切换中文输入法

Option Explicit

Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" _
        (ByVal pwszKLID As String) As Long
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" _
        (ByVal hkl As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long
Private Declare Function ActivateKeyboardLayout Lib "user32" _
        (ByVal hkl As Long, ByVal flags As Long) As Long
        
Const IME_CONFIG_GENERAL = 1
Const KLF_REORDER = &H8
Const KLF_ACTIVATE = &H1

Dim La(15) As Long
Dim LayoutName() As String

Private Sub Form_Load()
    '获取输入法
    Dim strTemp As String * 256
    Dim x As Integer, i As Integer
    
    '获得输入法总数
    x = GetKeyboardLayoutList(32, La(1))
    If x = 0 Then Exit Sub
    
    ReDim LayoutName(x) As String
    For i = 0 To x
        ImmGetDescription La(i), strTemp, 256
        
        If InStr(strTemp, Chr(0)) = 1 Then
            LayoutName(i) = "英语（美国）"
        Else
            LayoutName(i) = Left(strTemp, InStr(strTemp, Chr(0)))
        End If
    Next
    
    
    '加入列表
    For i = 0 To x
        Combo1.AddItem LayoutName(i)
    Next
    Combo1.ListIndex = 0
    
End Sub

Private Sub Text1_GotFocus()
    '设置输入法
    ActivateKeyboardLayout La(Combo1.ListIndex), 1
End Sub

查询回收站
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Query Recycle Bin"
   ClientHeight    =   2715
   ClientLeft      =   5505
   ClientTop       =   3660
   ClientWidth     =   3195
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2715
   ScaleWidth      =   3195
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   615
      Left            =   2550
      Picture         =   "Form1.frx":0000
      ScaleHeight     =   615
      ScaleWidth      =   615
      TabIndex        =   7
      Top             =   1575
      Width           =   615
   End
   Begin VB.CheckBox Check1 
      Caption         =   "全部"
      Height          =   375
      Left            =   150
      TabIndex        =   6
      Top             =   1560
      Width           =   1575
   End
   Begin VB.DriveListBox Drive1 
      Height          =   315
      Left            =   150
      TabIndex        =   3
      Top             =   150
      Width           =   2895
   End
   Begin VB.CommandButton Command1 
      Caption         =   "查看"
      Default         =   -1  'True
      Height          =   495
      Left            =   855
      TabIndex        =   0
      Top             =   2100
      Width           =   1485
   End
   Begin VB.Label Label4 
      Height          =   255
      Left            =   975
      TabIndex        =   5
      Top             =   1125
      Width           =   2040
   End
   Begin VB.Label Label2 
      Height          =   255
      Left            =   1815
      TabIndex        =   2
      Top             =   675
      Width           =   1200
   End
   Begin VB.Label Label3 
      Caption         =   "Bytes:"
      Height          =   255
      Left            =   150
      TabIndex        =   4
      Top             =   1125
      Width           =   840
   End
   Begin VB.Label Label1 
      Caption         =   "Number of Items:"
      Height          =   375
      Left            =   150
      TabIndex        =   1
      Top             =   675
      Width           =   1905
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function SHQueryRecycleBin Lib "shell32.dll" _
    Alias "SHQueryRecycleBinA" (ByVal pszRootPath As String, _
    pSHQueryRBInfo As SHQUERYRBINFO) As Long

Private Type int64
    LowPart As Long
    HighPart As Long
End Type

Private Type SHQUERYRBINFO
    cbSize As Long         '  SHQUERYRBINFO结构变量的大小
    i64Size As int64       '  回收站中对象大小
    i64NumItems As int64   '  回收站中对象数名
End Type

Private Sub Command1_Click()
    Dim pSHQueryRBInfo As SHQUERYRBINFO
    
    pSHQueryRBInfo.cbSize = Len(pSHQueryRBInfo)
    
    If Check1.Value Then
        SHQueryRecycleBin "", pSHQueryRBInfo
    Else
        SHQueryRecycleBin Drive1.Drive, pSHQueryRBInfo
    End If
    
    ' Items in Recycle Bin
    Label2.Caption = pSHQueryRBInfo.i64NumItems.LowPart
    
    ' Bytes in Recycle Bin
    Label4.Caption = pSHQueryRBInfo.i64Size.LowPart & " bytes"
End Sub

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



'任务栏的显示与隐藏

Private Const SW_HIDE = 0
Private Const SW_NORMAL = 1

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private hTaskWnd As Long
                                               
Private Sub Command1_Click()
    Call ShowWindow(hTaskWnd, SW_HIDE)
End Sub

Private Sub Command2_Click()
    Call ShowWindow(hTaskWnd, SW_NORMAL)
End Sub

Private Sub Form_Load()
    hTaskWnd = FindWindow("shell_traywnd", "")
End Sub


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

搜寻所有字体名称

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

Const CB_FINDSTRING = &H14C

Private Sub Combo1_Change()
    Dim iStart As Integer
    Dim sString As String
    Static iLeftOff As Integer
    
    iStart = 1
    iStart = Combo1.SelStart
    
    If iLeftOff <> 0 Then
        Combo1.SelStart = iLeftOff
        iStart = iLeftOff
    End If
    
    sString = CStr(Left(Combo1.Text, iStart))
    Combo1.ListIndex = SendMessage(Combo1.hwnd, B_FINDSTRING, -1, ByVal CStr(Left(ombo1.Text, iStart)))
    
    If Combo1.ListIndex = -1 Then
        iLeftOff = Len(sString)
        Combo1.Text = sString
    End If
    
    Combo1.SelStart = iStart
    iLeftOff = 0
End Sub

Private Sub Form_Load()
    Dim i As Integer
    For i = 0 To Screen.FontCount - 1
        Combo1.AddItem Screen.Fonts(i)
    Next i
End Sub


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


隐藏Windows开始按钮
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "隐藏Windows开始按钮"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.OptionButton Option1 
      Caption         =   "隐藏Windows开始按钮"
      Height          =   495
      Index           =   1
      Left            =   1268
      TabIndex        =   1
      Top             =   1650
      Width           =   2145
   End
   Begin VB.OptionButton Option1 
      Caption         =   "显示Windows开始按钮"
      Height          =   495
      Index           =   0
      Left            =   1268
      TabIndex        =   0
      Top             =   1050
      Value           =   -1  'True
      Width           =   2145
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
        (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
        ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" _
        (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const SW_HIDE = 0
Private Const SW_SHOW = 5

Private Sub Form_Unload(Cancel As Integer)
    If Option1(1).Value Then Call Option1_Click(0)
End Sub

Private Sub Option1_Click(Index As Integer)
    Dim hLong As Long
    Dim hwnd As Long
    
    hwnd = FindWindow("Shell_TrayWnd", vbNullString)
    hLong = FindWindowEx(hwnd, 0, "Button", vbNullString)
    
    Select Case Index
        Case 0
            ShowWindow hLong, SW_SHOW
        Case 1
            ShowWindow hLong, SW_HIDE
    End Select
End Sub

呵呵，LZ辛苦了

先收藏，慢慢消化

LZ辛苦

vbman2003(佳人)大哥还收藏呢，呵呵
我一起收藏过好多代码，都没时间看；
后来都丢了，
现在不用VB了，唉~

错字，汗
我一起收藏过 =〉我以前收藏过

强

“佳人”我是“见利妄为”，有好东西就先据为己有再说，呵呵

不过确实平时很少有时间去看，不过真正遇到问题的时候，还是先会到收藏夹中去看看。

原来大家都这样的啊
我有时候看到大家贴出好的东西拉
都要收藏着呢
想自己慢慢消化 整合到自己的Demo中
后来觉得这也满累的 就算了
等什么时候遇到问题
再去看看 嘿嘿

启动控制面板
 

'{打开控制面板}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL", 9)
'{辅助选项 属性-键盘}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1", 9)
'{辅助选项 属性-声音}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2", 9)
'{辅助选项 属性-显示}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3", 9)
'{辅助选项 属性-鼠标}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4", 9)
'{辅助选项 属性-常规}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5", 9)
'{添加/删除程序 属性-安装/卸载}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,1", 9)
'{添加/删除程序 属性-Windows安装程序}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,2", 9)
'{添加/删除程序 属性-启动盘}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,3", 9)
'{显示 属性-背景}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 9)
'{显示 属性-屏幕保护程序}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", 9)
'{显示 属性-外观}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", 9)
'{显示 属性-设置}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", 9)
'{Internet 属性-常规}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,0", 9)
'{Internet 属性-安全}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,1", 9)
'{Internet 属性-内容}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,2", 9)
'{Internet 属性-连接}
Call Shell("rundll32.exe shell32.dll,Control_RunDLL I
 
------------------------------------------------------
'重新启动Windows 2000 / NT系统

'Reboots a Windows 2000 PC. Many examples shell to the kernel and just kill the PC. This does it properly and takes into account a user privilages.

'API Calls used for RebootPC

Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_QUERY = &H8
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const EWX_SHUTDOWN As Long = 1
Private Const EWX_FORCE As Long = 4
Private Const EWX_REBOOT = 2


Private Type LUID
    UsedPart As Long
    IgnoredForNowHigh32BitPart As Long
End Type

Private Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    TheLuid As LUID
    Attributes As Long
End Type

Private Declare Function ExitWindowsEx Lib "user32" _
        (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32" _
        (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _
        (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" _
        (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _
        NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _
        PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long


Sub RebootPC()
    On Local Error GoTo RebootPC_ErrorHandler
    Const csProcName = "RebootPC"
 
    Dim hProcessHandle As Long
    Dim hTokenHandle As Long
    Dim tmpLuid As LUID
    Dim tkpNew As TOKEN_PRIVILEGES
    Dim tkpPrevious As TOKEN_PRIVILEGES
    Dim lBufferNeeded As Long

    hProcessHandle = GetCurrentProcess()
    Call OpenProcessToken(hProcessHandle, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hTokenHandle)

    ' Get the LUID for the shutdown privilege
    Call LookupPrivilegeValue("", "SeShutdownPrivilege", tmpLuid)

    tkpNew.PrivilegeCount = 1 ' One privilege to set
    tkpNew.TheLuid = tmpLuid
    tkpNew.Attributes = SE_PRIVILEGE_ENABLED

    ' Enable the shutdown privilege in the access token of this process.
    lBufferNeeded = 0
    Call AdjustTokenPrivileges(hTokenHandle, False, tkpNew, Len(tkpPrevious), tkpPrevious, lBufferNeeded)

    ' Force a Reboot (no option to save files to cancel out)
    Call ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, &HFFFF)

    Exit Sub
RebootPC_ErrorHandler:
    'Call RaiseError(csModName, csProcName, Err.Number, Err.Description)
End Sub

Private Sub Command1_Click()
    RebootPC
End Sub


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


模拟喷枪(鼠标轨迹)
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "Paint (右键单击-清空)"
   ClientHeight    =   4125
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5955
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4125
   ScaleWidth      =   5955
   StartUpPosition =   3  '窗口缺省
   WindowState     =   2  'Maximized
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1
      Left            =   1755
      Top             =   1350
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOW = 5

Dim nX, nY As Long

Private Sub Form_Activate()
    With Me
        .AutoRedraw = True
        .BackColor = vbWhite
    End With
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Timer1.Enabled = True
        nX = X
        nY = Y
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Timer1.Enabled = True
        nX = X
        nY = Y
    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = False
    '鼠标右键单击，清空
    If Button = 2 Then Me.Cls
End Sub

Private Sub Timer1_Timer()
    Me.DrawWidth = 1
    For i = -10 To 10
        For j = -10 To 10
            PSet (nX + Rnd * i * 100, nY + Rnd * j * 100)
        Next j
    Next i
End Sub



--------------------------------------------------------------
VB中App.path的注意事项  
     VB中,App.path可以返回当前执行文件的所在文件夹,使得程序放在硬盘的任何地方都能正常运行,这个方法在编VB时很常用。如：我把我的程序及相关文件放在c:\programx中,运行该文件夹下的xxx.exe（即c:\programx\xxx.exe）,而程序中要调用该文件夹下的pic1.jpg,则该路径可以写成App.path & "\pic1.jpg",其中App.path返回的值为"c:\programx",这样,即使把c:中的programx文件夹搬到d:\,返回路径也会自动变成"d:\programx\pic1.jpg"。这个程序看来似乎没有问题,但是,如果我们把c:\programx\下的文件全都搬到d:\下,而不放在任何文件夹下,返回的路径就会变成"d:\\pic1.jpg",发生错误！还有,如果程序中使用了DirListBox的path属性来返回路径时,也会发生类似的错误。因此,程序中必须对这些情况做相应处理。

    Dim strPath As String
    strPath = App.path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

屏幕放大镜
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   3000
   ClientLeft      =   45
   ClientTop       =   390
   ClientWidth     =   3000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   200
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   200
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer Timer1 
      Interval        =   10
      Left            =   0
      Top             =   0
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Const Srccopy = &HCC0020
Const Swp_nomove = &H2
Const Swp_nosize = &H1
Const Flags = Swp_nomove Or Swp_nosize
Const hwnd_topmost = -1

Private Declare Function SetWindowPos Lib "user32" _
        (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
        ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
        ByVal wFlags As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" _
        (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
        ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
        ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Dim pos As POINTAPI

Private Sub Form_Load()
    SetWindowPos hwnd, hwnd_topmost, 0, 0, 0, 0, Flags
End Sub

Private Sub start()
    Dim sx As Integer
    Dim sy As Integer
    GetCursorPos pos
    sx = IIf(pos.x < 50 Or pos.x > 590, IIf(pos.x < 50, 0, 540), pos.x - 50)
    sy = IIf(pos.y < 50 Or pos.y > 430, IIf(pos.y < 50, 0, 380), pos.y - 50)
    Caption = "坐标" & sx & "," & sy
    StretchBlt hdc, 0, 0, 200, 200, GetDC(0), sx, sy, 100, 100, Srccopy
End Sub

Private Sub Timer1_Timer()
    start
End Sub


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

随机图像的魅力
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5490
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7365
   LinkTopic       =   "Form1"
   ScaleHeight     =   5490
   ScaleWidth      =   7365
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command5 
      Caption         =   "Command5"
      Height          =   495
      Left            =   5760
      TabIndex        =   6
      Top             =   4200
      Width           =   1215
   End
   Begin VB.CommandButton Command4 
      Caption         =   "Command4"
      Height          =   495
      Left            =   4440
      TabIndex        =   5
      Top             =   4200
      Width           =   1215
   End
   Begin VB.CommandButton Command3 
      Caption         =   "Command3"
      Height          =   495
      Left            =   3120
      TabIndex        =   4
      Top             =   4200
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   495
      Left            =   1800
      TabIndex        =   3
      Top             =   4200
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   495
      Left            =   480
      TabIndex        =   2
      Top             =   4200
      Width           =   1215
   End
   Begin VB.PictureBox Picture2 
      Height          =   3735
      Left            =   3840
      Picture         =   "Form1.frx":0000
      ScaleHeight     =   3675
      ScaleWidth      =   3315
      TabIndex        =   1
      Top             =   240
      Width           =   3375
   End
   Begin VB.PictureBox Picture1 
      Height          =   3735
      Left            =   360
      ScaleHeight     =   3675
      ScaleWidth      =   3315
      TabIndex        =   0
      Top             =   240
      Width           =   3375
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'随机图像的魅力
'在VB中提供了相当强的绘图功能, 可以在窗口或图形框中利用各种命令绘制各种图形,
'灵活使用这些绘图命令不仅可以完成许多特殊的功能, 而且可以为WINDOWS 的程序界面增加许多活力,
'特别是那些巧妙的随机图像则更具有特殊的魅力, 下面仅以三种随机动画为例, 演示VB中随机动画图像的风采。

'一?随机简单图形动画
'---- 完成此工作主要的直接使用VB中的作图命令, 比如画点函数PSet(X,Y),COLOR,
'其中X Y为图形坐标系统的坐标, COLOR表示颜色值,可用QBColor(x)或RGB(r,g,b)等形式表示,
'同时可以控制画点的半径长度,即通过设置Drawwidth 属性, 当半径大于1时实际上此命令是画一个实心圆,
'当然也可以利用Circle命令直接绘制圆形。VB中还提供了随机数产生手段,即RND内部函数,
'它可以产生0到1之间的随机数, 利用此函数可以随机确定画点的位置、点的颜色、点的半径等，
'这样即可以实现在固定区域内进行随机画圆操作, 其中随机位置的确定必须根据作图区域进行确定,
'具体可用 ScaleWidth及Scaleheight属性进行确定。为了实现连续动画效果,
'可利用时间控件或"DoEvents" 命令实现后台处理, 具体请见文后的Command1_Click事件中的程序代码。
'如果把程序改为随机画矩形或空心圆，或者灵活控制画圆的半径, 则会产生另外的艺术效果,
'比如在一片黑色的屏幕上画出随机的小点, 就象夜空中的点点繁星。

'二?随机文字动画
'---- 在VB中可利用"Print"命令进行字符串的显示工作,此命令一般只在当前位置显示字符串,
'但具体操作时可通过 CurrentX和CurrentY 控制字符串显示位置,通过FontSize 控制字体的尺寸,
'通过ForeColor和BackColor控制字符的前景色和背景色, 如果把上述的各项属性值均采用RND 进行随机产生,
'即会形成随机字符显示效果, 比如在一个图形框中显示一些新年贺辞, 同时播放美妙的音乐,
'那将是一份极好的新年礼物。需要注意一点，由于字体互相覆盖，长时间显示会使窗口显得乱一些，
'所以最好按一定时间用 "CLS"命令进行窗口清除。此处说明一下颜色的控制技巧,
'如果使用QBColor(Rnd*15)方式定义随机颜色,只能在16种颜色中随机产生,
'而采用RGB(Rnd*256,Rnd*256,Rnd*256) 方式则可以产生256*256*256种不同的颜色,
'但具体的颜色特性受当前WINDOWS 屏幕模式的限制。具体操作方式请见文后Command2_Click事件中的代码。

'三?立体图形随机动画
'---- 上面只是直接利用绘图语句进行简单的动画, 如果通过这些命令绘制成一定的立体图形,
'并实行随机动画操作, 那将更具有特殊的艺术效果。
'比如下面两行简单的命令将画出一个具有强烈立体感效果的三角锥体, 其中(M,N) 为锥体的顶端坐标:
'Picture1.Line (m, n + 2.5 * i)-(m + i / 2, n + 2 * i), RGB(180, 180, 180)
'Picture1.Line (m, n + 2.5 * i)-(m - i / 2, n + 2 * i), RGB(80, 80, 80)
'---- 如果把屏幕的底色置为暗黄色, 在此窗口内的随机位置画出大小不一的三角锥,
'就象在黄色的沙漠上建起了无数的金字塔, 具有一种特殊的情趣。
'具体操作方法请见文后程序中的Command3_Click事件中的代码。

'四?随机显示图像
'---- 在VB中不仅提供了完善的做图方法, 而且在绘图方法中还可以灵活的处理图像文件,
'其中提供了一个方便的图像复制命令即: PaintPicture, 此命令的功能与API 函数 BitBlt类似,
'但由于不用做API函数说明,所以更有它的方便之处, 语法格式:
'PaintPicture Pic, destX, destY, destWidth, destHeight, scrX, scrY, scrWidth, scrHeight
'其中Pic:为图片对象, 如图形框Picture等;
'destX,destY:目标图像位置;
'destWidth,destHeight:目标图像尺寸;
'scrX,scrY:原图像的裁剪坐标;
'scrWidth,scrHeight:原图像的裁剪尺寸;

'---- 从以上可以看出，目标图像的位置可以随机改变，不仅如此，通过改变destWidth与destHeight值,
'还可以改变复制后的图像的尺寸, 实现放大或缩小图像显示, 甚至可以置这两个属性为负值,
'这样可使目标图像在水平方向翻转，实现特殊效果的图像显示, 灵活运用RND 随机函数确定上述各个参数,
'可取得理想的随机图像显示效果。具体操作方法请见文后程序Command4_Click事件中的代码。
'---- 文后是一个完成上述随机动画的完整演示程序，需要在From1 窗体中安放两个图形框Picture(1-2)
'及四个命令按钮Command1-5,然后把下面的代码填入相应的事件处,运行此程序之后,
'按下按钮1则在图形框中进行随机画圆演示,
'按下按钮2 则在图形框中进行随机文字显示,
'按下按钮 3 则在图形框中随机显示三角锥体,
'按下按钮4 则进行随机图像显示,
'按下按钮5 则退出程序。
(待续)

(续)
'注释: 程序准备
Private Sub Form_Load()
    Command1.Caption = "随机画圆"
    Command2.Caption = "随机文字"
    Command3.Caption = "立体图形"
    Command4.Caption = "随机图像"
    Command5.Caption = "退出"
    Form1.ScaleMode = 1
    Picture1.ScaleMode = 1
End Sub

'注释: 随机画圆动画
Private Sub Command1_Click()
    Dim XPos, YPos
    Picture1.Cls
    Do
        nn = Int(100 * Rnd)
        If nn > 0 Then
            Picture1.DrawWidth = nn
        End If
        XPos = Rnd * Picture1.ScaleWidth
        YPos = Rnd * Picture1.ScaleHeight
        Picture1.PSet (XPos, YPos), RGB(Rnd * 256, Rnd * 256, Rnd * 256)
        DoEvents
    Loop
End Sub

'注释: 随机文字动画
Private Sub Command2_Click()
    Picture1.Cls
    Do
        nn = Int(45 * Rnd)
        If nn > 0 Then
            Picture1.FontSize = nn
        End If
        Picture1.CurrentX = Rnd * Picture1.ScaleWidth - 1000
        Picture1.CurrentY = Rnd * Picture1.ScaleHeight
        Picture1.ForeColor = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
        Picture1.Print "随机 OK!"
        n = n + 1
        If n > 50 Then
            n = 0
            Picture1.BackColor = QBColor(Rnd * 15)
        End If
        DoEvents
    Loop
End Sub

'注释: 立体随机动画
Private Sub Command3_Click()
    Dim m, n
    Picture1.DrawWidth = 1
    Picture1.BackColor = RGB(210, 150, 0)
    Picture1.Cls
    Do
        m = Rnd * Picture1.ScaleWidth
        n = Rnd * Picture1.ScaleHeight - 500
        For i = 0 To Rnd * 800
            Picture1.Line (m, n + 2.5 * i)-(m + i / 2, n + 2 * i), RGB(180, 180, 180)
            Picture1.Line (m, n + 2.5 * i)-(m - i / 2, n + 2 * i), RGB(80, 80, 80)
        Next i
        DoEvents
    Loop
End Sub

'注释: 随机图像显示
Private Sub Command4_Click()
    Do
        xx = Rnd * Picture1.Width
        yy = Rnd * Picture1.Height
        Picture1.PaintPicture Picture2.Picture, xx, yy, Picture2.Width, Picture2.Height
        DoEvents
    Loop
End Sub

'注释: 退出按钮
Private Sub Command5_Click()
    End
End Sub

读写ini配置文件的模块
【Class Code:将下面代码用记事本保存为 CIniFile.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 = "CIniFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
        (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
        ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" _
        (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, _
        ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
        (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
        ByVal lpDefault As String, ByVal lpReturnedString As String, _
        ByVal nSize As Long, ByVal lpFileName As String) As Long

'INI文件名和错误信息
Private IniFileName As String
Public ErrorMsg As String


    '------------------------------------------------------------
    '调用方法：
    'Dim IniF As New CIniFile
    'IniF.SpecifyIni (App.Path & "\Temp.ini")
    
    '写入键
    'IniF.WriteString "段名", "键名", "键值"
    
    '读取键值
    'Dim P As String
    'P = IniF.ReadString("段名", "键名", 20)  '20是长度
    '------------------------------------------------------------
    

'对属性进行初始化
Private Sub Class_Initialize()
    IniFileName = vbNullString
    ErrorMsg = vbNullString
End Sub
  
'指定INI文件名
Public Sub SpecifyIni(FilePathName)
    IniFileName = Trim(FilePathName)
End Sub

'如果没有指定INI文件
Private Function NoIniFile() As Boolean
    NoIniFile = True
    If IniFileName = vbNullString Then
        ErrorMsg = "没有指定 INI 文件"
        Exit Function
    End If
    ErrorMsg = vbNullString
    NoIniFile = False
End Function
 
'向INI文件中写入一个键值，如果键和section不存在则创建
Public Function WriteString(Section As String, key As String, _
        Value As String) As Boolean
    
    WriteString = False
    If NoIniFile() Then
        Exit Function
    End If
    If WritePrivateProfileString(Section, key, Value, IniFileName) = 0 Then
        ErrorMsg = "写入失败"
        Exit Function
    End If
    WriteString = True
End Function

'在 INI 文件中读取一个键值，作为字符串返回
Public Function ReadString(Section As String, key As String, _
        Size As Long) As String
    
    Dim ReturnStr As String
    Dim ReturnLng As Long
    ReadString = vbNullString
    If NoIniFile() Then
        Exit Function
    End If
    ReturnStr = Space(Size)
    ReturnLng = GetPrivateProfileString(Section, key, _
            vbNullString, ReturnStr, Size, IniFileName)
    ReadString = Left(ReturnStr, ReturnLng)
End Function
 
'在INI文件中读取一个整数值
Public Function ReadInt(Section As String, key As String) As Long
    Dim ReturnLng As Long
    ReadInt = 0
    ReturnLng = GetPrivateProfileInt(Section, key, 0, IniFileName)
    If ReturnLng = 0 Then
        ReturnLng = GetPrivateProfileInt(Section, key, 1, IniFileName)
        If ReturnLng = 1 Then
            ErrorMsg = "不能读取"
            Exit Function
        End If
    End If
    ReadInt = ReturnLng
End Function
 


------------------------------------------------------------
设置文件的属性
'Form Code:

'方法一
'SetAttr
'语法:SetAttr pathname, Attributes
'pathname 必要参数。用来指定一个文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。
'Attributes 必要参数。常数或数值表达式，其总和用来表示文件的属性。
'Attributes 参数设置可为:
'常数 值 描述
'vbNormal 0 常规（缺省值）
'VbReadOnly 1 只读。
'vbHidden 2 隐藏。
'vbSystem 4 系统文件
'vbArchive 32 上次备份以后，文件已经改变

'注意 这些常数是由 VBA 所指定的，在程序代码中的任何位置，可以使用这些常数来替换真正的数值。
'如果想要给一个已打开的文件设置属性，则会产生运行时错误。

Private Sub Command1_Click()
    SetAttr App.Path & "\abc.txt", vbHidden + vbReadOnly
End Sub

'方法二 API函数,见模块代码
Private Sub Command2_Click()
    '设置为只读 + 隐藏
    SetFileA App.Path & "\abc.txt"
    '读取属性
    Debug.Print GetFileA(App.Path & "\abc.txt")
End Sub


'Class Code:

'设置属性
Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" _
        (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
'读取属性
Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _
        (ByVal lpFileName As String) As Long

Const FILE_ATTRIBUTE_READONLY = &H1 '只读
Const FILE_ATTRIBUTE_HIDDEN = &H2   '隐藏
Const FILE_ATTRIBUTE_SYSTEM = &H4   '系统
'Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_ARCHIVE = &H20 '保存(存档)
Const FILE_ATTRIBUTE_NORMAL = &H80  '常规(一般)
Const FILE_ATTRIBUTE_TEMPORARY = &H100  '临时
Const FILE_ATTRIBUTE_COMPRESSED = &H800 '压缩
'要设置两种以上属性,可用 OR 或 + 连接

Public Sub SetFileA(ByVal FileName As String)
    '设置为只读 + 隐藏
    SetFileAttributes FileName, FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_HIDDEN
    '取消设置(设置成常规)
    'SetFileAttributes FileName, FILE_ATTRIBUTE_NORMAL
End Sub

Public Function GetFileA(ByVal FileName As String) As String
    '读取文件属性
    Dim strFileAttr As String
    Dim FileAtt
    FileAtt = GetFileAttributes(FileName)
    If FileAtt And FILE_ATTRIBUTE_READONLY Then strFileAttr = strFileAttr & "只读 "
    If FileAtt And FILE_ATTRIBUTE_HIDDEN Then strFileAttr = strFileAttr & "隐藏 "
    If FileAtt And FILE_ATTRIBUTE_SYSTEM Then strFileAttr = strFileAttr & "系统 "
    If FileAtt And FILE_ATTRIBUTE_ARCHIVE Then strFileAttr = strFileAttr & "存档 "
    If FileAtt And FILE_ATTRIBUTE_NORMAL Then strFileAttr = strFileAttr & "常规 "
    If FileAtt And FILE_ATTRIBUTE_TEMPORARY Then strFileAttr = strFileAttr & "临时 "
    If FileAtt And FILE_ATTRIBUTE_COMPRESSED Then strFileAttr = strFileAttr & "压缩 "
    
    GetFileA = strFileAttr
End Function

---------------------------------------------------
改变ListIndex而不发生Click事件
'Form Code:
'在修改 Combo 或 Listview 的ListIndex 时， 会发生 Click 事件， 下面的函数可以阻止该事件

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

Const CB_GETCURSEL = &H147
Const CB_SETCURSEL = &H14E
Const LB_SETCURSEL = &H186
Const LB_GETCURSEL = &H188

Public Function SetListIndex(lst As Control, ByVal NewIndex As Long) As Long
    '改变ListIndex而不发生Click事件
    If TypeOf lst Is ListBox Then
        Call SendMessage(lst.hWnd, LB_SETCURSEL, NewIndex, 0&)
        SetListIndex = SendMessage(lst.hWnd, LB_GETCURSEL, NewIndex, 0&)
    ElseIf TypeOf lst Is ComboBox Then
        Call SendMessage(lst.hWnd, CB_SETCURSEL, NewIndex, 0&)
        SetListIndex = SendMessage(lst.hWnd, CB_GETCURSEL, NewIndex, 0&)
    End If
End Function

Private Sub Combo1_Click()
    '测试Click事件是否发生
    Print Combo1.Text
End Sub

Private Sub Command1_Click()
    '设置控件ListIndex=2
    SetListIndex Combo1, 2
End Sub

Private Sub Command2_Click()
    ''设置控件ListIndex=3
    Combo1.ListIndex = 3
End Sub

Private Sub Form_Load()
    '添加几个项
    Dim i As Integer
    For i = 0 To 5
        Combo1.AddItem "项目" & i
    Next
End Sub

关闭MDI窗体中所有的子窗体
建立一个新工程,自然有一个默认Form1存在了,然后设置为子窗体(MDIChild=1),再按下列方法操作并加载此MDI窗体:
【Form Code:将下面代码用记事本保存为 MDIForm1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00
Begin VB.MDIForm MDIForm1 
   BackColor       =   &H8000000C&
   Caption         =   "MDIForm1"
   ClientHeight    =   6195
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   9375
   LinkTopic       =   "MDIForm1"
   StartUpPosition =   3  '窗口缺省
   Begin VB.Menu mnu_x 
      Caption         =   "菜单"
      Begin VB.Menu mnu_addnew 
         Caption         =   "添加一个子窗口"
      End
      Begin VB.Menu mnu_cls 
         Caption         =   "关闭所有子窗口"
      End
   End
End
Attribute VB_Name = "MDIForm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'关闭MDI窗体中所有的子窗体

Private Sub mnu_addnew_Click()
    '添加新子窗体
    Dim f As New Form1
    Static i As Integer
    i = i + 1
    f.Caption = "新窗口-" & i
End Sub

Private Sub mnu_cls_Click()
    '卸载所有子窗体
    Screen.MousePointer = vbHourglass

    Do While Not (Me.ActiveForm Is Nothing)
        Unload Me.ActiveForm
    Loop
    Screen.MousePointer = vbDefault
End Sub


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

利用 UnloadMode 来控制窗体的卸载


'在QueryUnload事件中,Visual Basic提供了UnloadMode参数,利用这个参数,
'我们可以控制窗体的卸载.

Option Explicit

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    '若不是用代码卸载,则失效
    If UnloadMode <> 1 Then
        Cancel = True
    End If
End Sub

'UnloadMode 参数返回下列值:
'常数                  值        描述
'vbFormControlMenu    0     用户从窗体上的“控件”菜单中选择“关闭”指令。
'vbFormCode           1     Unload 语句被代码调用。
'vbAppWindows         2     当前 Microsoft Windows 操作环境会话结束。
'vbAppTaskManager     3     Microsoft Windows 任务管理器正在关闭应用程序。
'vbFormMDIForm        4     MDI 子窗体正在关闭，因为 MDI 窗体正在关闭。
 

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

'强制和防止窗口重画csdngoodnight(E-mail:kxufeng@163.com)
'两个按钮和一个CheckBox,一个ListBox

'代码
'以下这两条声明对应Command2
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Sub Command2_Click()
    '这则代码演示了如何防止窗口的一部分重画。
    '当你要往ListBox或ListView这样的控件里添加许多项时，暂缓重画可以相当地提高处理速度。
    '在我的系统上，往一个ListBox中加10000项比原来提速平均82%(CPU:P M 1200Hz)
    
    '当你单击Command按钮，代码将往ListBox中添加10000项。
    '如果Check1的复选框被选中，Windows将在往ListBox中添加项时防止它的重画。
    '操作结束后，会弹出一个对话框报告运行时间。
    Dim i As Long
    Dim lTIme As Long
    
    lTIme = timeGetTime()
    
    If (Check1.Value = Checked) Then
        LockWindowUpdate List1.hWnd
    End If
    
    List1.Clear
    For i = 1 To 10000
        List1.AddItem "Test " & i
    Next i
    
    If (Check1.Value = Checked) Then
        LockWindowUpdate 0
        List1.Refresh
    End If
    
    MsgBox "消耗时间: " & timeGetTime - lTIme
  
End Sub



Private Sub Command1_Click()
    '其余代码见模块
    '当你单击Command按钮，ListBox的客户区将全部重画。
    '对于ListBox，这种效果并不十分明显地显示(会闪动一下,将ListBox控件拉大可以明显些看见效果)，
    '但这段代码放在这里主要目的，是让你在遇上有东西不能恰当地重画它自己时
    '可以有办法解决.
    RepaintWindow List1
End Sub

Private Sub Form_Load()
    Dim i As Long
    For i = 1 To 200
        List1.AddItem "TestItem " & i
    Next i
End Sub


--------------------------------------------------------
获得系统内存信息

'模块:
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type

Public Function GetMemoryInfo()
    '获得系统内存信息
    Dim Msg As String
    Dim MemSts As MEMORYSTATUS
    Dim l As Long
    
    GlobalMemoryStatus MemSts
    
    Msg = "系统内存信息" & vbCrLf
    l = MemSts.dwTotalPhys
    Msg = Msg & "物理内存总量:" & Format(l \ 1024, "###,###,###") & "KB" & vbCrLf
    l = MemSts.dwAvailPhys
    Msg = Msg & "可用物理内存:" & Format(l \ 1024, "###,###,###") & "KB" & vbCrLf
    l = MemSts.dwTotalVirtual
    Msg = Msg & "虚拟内存总量:" & Format(l \ 1024, "###,###,###") & "KB" & vbCrLf
    l = MemSts.dwAvailVirtual
    Msg = Msg & "可用虚拟内存:" & Format(l \ 1024, "###,###,###") & "KB"
    Debug.Print Msg
    'Debug.Print MemSts.dwAvailPageFile \ 1024
    'Debug.Print MemSts.dwLength
    'Debug.Print MemSts.dwTotalPageFile \ 1024
    'Debug.Print MemSts.dwMemoryLoad
End Function

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

取得屏幕分辨率:
msgbox screen.width/15 & " x " & screen.height/15

-------------------------------------------------------------------------
'无标题栏窗口的拖曳

Private Declare Function ReleaseCapture Lib "user32" () As Long
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 WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ReleaseCapture
    SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0
    'SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    '上述两种方法都能实现该功能。
End Sub


'另有一例,我觉得这样看起来更舒服些:
'窗口拖曳相关(同样适用于控件)
Dim boolForm_Draw As Boolean
Dim sng_DrawX As Single, sng_DrawY As Single

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '如果左键按下
    If Button = 1 Then
        boolForm_Draw = True
        sng_DrawX = X
        sng_DrawY = Y
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If boolForm_Draw Then Move Me.Left + X - sng_DrawX, Me.Top + Y - sng_DrawY
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    boolForm_Draw = False
End Sub

'在程序中注册和注销 OCX 控件

'ComCtl32.OCX 要出测注册或反注册的控件名,在C:\WINDOWS\system32(即系统目录)内
Private Declare Function RegComCtl32 Lib "ComCtl32.OCX" Alias "DllRegisterServer" () As Long
Private Declare Function UnRegComCtl32 Lib "ComCtl32.OCX" Alias "DllUnregisterServer" () As Long
Const ERROR_SUCCESS = &H0

Private Sub Command1_Click()
    On Error GoTo xErr
    If RegComCtl32 = ERROR_SUCCESS Then
        MsgBox "注册成功"
    Else
        MsgBox "注册失败"
    End If
    Exit Sub
xErr:
    If Err.Number = 53 Then MsgBox "没有此文件"
End Sub

Private Sub Command2_Click()
    On Error GoTo xErr
    If UnRegComCtl32 = ERROR_SUCCESS Then
        MsgBox "反注册成功"
    Else
        MsgBox "反注册失败"
    End If
    Exit Sub
xErr:
    If Err.Number = 53 Then MsgBox "没有此文件"
End Sub


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

'VB应用程序中打印条形码的方法
'原作者:四川　李佑民

'下面就是我们给出的子过程:
'将字符串 strBarCode 对应的条形码输出到缺省打印机

Private Sub PrintBarCode(ByVal strBarCode As String, _
                         Optional ByVal intXPos As Integer = 0, _
                         Optional ByVal intYPos As Integer = 0, _
                         Optional ByVal intPrintHeight As Integer = 10, _
                         Optional ByVal bolPrintText As Boolean = True)

    '参数说明:
    'strBarCode - 要打印的条形码字符串
    'intXPos, intYPos - 打印条形码的左上角坐标(缺省为(0,0),坐标刻度为:毫米)
    'intHeight - 打印高度(缺省为一厘米,坐标刻度为:毫米)
    'bolPrintText - 是否打印人工识别字符(缺省为true)
    
    If strBarCode = "" Then Exit Sub '不打印空串
    
    '"0-9","A-Z","-","%","$"和"*" 的条码编码格式,总共 40 个字符
    Static strBarTable(39) As String
    '初始化条码编码格式表
    strBarTable(0) = "001100100"     '0
    strBarTable(1) = "100010100"     '1
    strBarTable(2) = "010010100"     '2
    strBarTable(3) = "110000100"     '3
    strBarTable(4) = "001010100"     '4
    strBarTable(5) = "101000100"     '5
    strBarTable(6) = "011000100"     '6
    strBarTable(7) = "000110100"     '7
    strBarTable(8) = "100100100"     '8
    strBarTable(9) = "010100100"     '9
    strBarTable(10) = "100010010"    'A
    strBarTable(11) = "010010010"    'B
    strBarTable(12) = "110000010"    'C
    strBarTable(13) = "001010010"    'D
    strBarTable(14) = "101000010"    'E
    strBarTable(15) = "011000010"    'F
    strBarTable(16) = "000110010"    'G
    strBarTable(17) = "100100010"    'H
    strBarTable(18) = "010100010"    'I
    strBarTable(19) = "001100010"    'J
    strBarTable(20) = "100010001"    'K
    strBarTable(21) = "010010001"    'L
    strBarTable(22) = "110000001"    'M
    strBarTable(23) = "001010001"    'N
    strBarTable(24) = "101000001"    'O
    strBarTable(25) = "011000001"    'P
    strBarTable(26) = "000110001"    'Q
    strBarTable(27) = "100100001"    'R
    strBarTable(28) = "010100001"    'S
    strBarTable(29) = "001100001"    'T
    strBarTable(30) = "100011000"    'U
    strBarTable(31) = "010011000"    'V
    strBarTable(32) = "110001000"    'W
    strBarTable(33) = "001011000"    'X
    strBarTable(34) = "101001000"    'Y
    strBarTable(35) = "011001000"    'Z
    strBarTable(36) = "000111000"    '-
    strBarTable(37) = "100101000"    '%
    strBarTable(38) = "010101000"    '$
    strBarTable(39) = "001101000"    '*

    '保存打印机 ScaleMode
    Dim intOldScaleMode As ScaleModeConstants
    intOldScaleMode = Printer.ScaleMode

    '保存打印机 DrawWidth
    Dim intOldDrawWidth As Integer
    intOldDrawWidth = Printer.DrawWidth

    '保存打印机 Font
    Dim fntOldFont As StdFont
    Set fntOldFont = Printer.Font

    Printer.ScaleMode = vbTwips     '设置打印用的坐标刻度为缇(twip=1)
    Printer.DrawWidth = 1         '线宽为 1
    Printer.FontName = "宋体"     '打印在条码下方字符的字体和大小
    Printer.FontSize = 10

    Dim strBC As String             '要打印的条码字符串
    strBC = UCase(strBarCode)

    '将以毫米表示的 X 坐标转换为以缇表示
    Dim x As Integer
    x = Printer.ScaleX(intXPos, vbMillimeters, vbTwips)

    '将以毫米表示的 Y 坐标转换为以缇表示
    Dim y As Integer
    y = Printer.ScaleY(intYPos, vbMillimeters, vbTwips)

    '将以毫米表示的高度转换为以缇表示
    Dim intHeight As Integer
    intHeight = Printer.ScaleY(intPrintHeight, vbMillimeters, vbTwips)
   

    '是否在条形码下方打印人工识别字符
    If bolPrintText = True Then
        '条码打印高度要减去下面的字符显示高度
        intHeight = intHeight - Printer.TextHeight(strBC)
    End If

    Const intWidthCU As Integer = 30     '粗线和宽间隙宽度
    Const intWidthXI As Integer = 10     '细线和窄间隙宽度
    
    Dim intIndex As Integer                '当前处理的字符串索引
    Dim i As Integer, j As Integer, k As Integer        '循环控制变量

    '添加起始字符
    If Left(strBC, 1) <> "*" Then
        strBC = "*" & strBC
    End If

    '添加结束字符
    If Right(strBC, 1) <> "*" Then
        strBC = strBC & "*"
    End If

    '循环处理每个要显示的条码字符
    For i = 1 To Len(strBC)
        '确定当前字符在 strBarTable 中的索引
        Select Case Mid(strBC, i, 1)
            Case "*": intIndex = 39
            Case "$": intIndex = 38
            Case "%": intIndex = 37
            Case "-": intIndex = 36
            Case "0" To "9": intIndex = CInt(Mid(strBC, i, 1))
            Case "A" To "Z": intIndex = Asc(Mid(strBC, i, 1)) - Asc("A") + 10
            Case Else
                MsgBox "要打印的条形码字符串中包含无效字符！当前版本只支持字符 0-9,A-Z,-,%,$和*"
        End Select
        
        '是否在条形码下方打印人工识别字符
        If bolPrintText = True Then
            Printer.CurrentX = x
            Printer.CurrentY = y + intHeight
            Printer.Print Mid(strBC, i, 1)
        End If

        For j = 1 To 5
            If Mid(strBarTable(intIndex), j, 1) = "0" Then
                '画细线
                For k = 0 To intWidthXI - 1
                    Printer.Line (x + k, y)-Step(0, intHeight)
                Next k
                x = x + intWidthXI
            Else
                '画宽线
                For k = 0 To intWidthCU - 1
                    Printer.Line (x + k, y)-Step(0, intHeight)
                Next k
                x = x + intWidthCU
            End If

            '每个字符条码之间为窄间隙
            If j = 5 Then
                x = x + intWidthXI * 3
                Exit For
            End If
            
            If Mid(strBarTable(intIndex), j + 5, 1) = "0" Then
                '窄间隙
                x = x + intWidthXI * 3
            Else
                '宽间隙
                x = x + intWidthCU * 2
            End If
        Next j
    Next i
    
    Printer.EndDoc  '若不想单独打出一页来,可插入其它代码,再回头调此句
    
    '恢复打印机 ScaleMode
    Printer.ScaleMode = intOldScaleMode
    '恢复打印机 DrawWidth
    Printer.DrawWidth = intOldDrawWidth
    '恢复打印机 Font
    Set Printer.Font = fntOldFont
End Sub

'##形状不规则的窗体(超简单,又好用)


Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" _
        (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'SetLayeredWindowAttributes 参数:
'hwnd:窗体的句柄
'crKey:颜色值
'bAlpha:透明度,取值范围:0-255
'dwFlags:透明方式,可以取两个值:当取值为LWA_ALPHA时,crKey参数无效,bAlpha参数有效;
'当取值为LWA_COLORKEY时,bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明[这个功能很有用,我喜欢] :)
'我们不必再为建立不规则形状的窗体而调用一大堆区域分析、创建、合并函数了,只需指定透明处的颜色值即可,哈哈哈哈!
'原作者：iProgram

Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1

'代码一: 半透明窗体
'Private Sub Form_Load()
'    Dim rtn As Long
'    rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
'    rtn = rtn Or WS_EX_LAYERED
'    SetWindowLong hwnd, GWL_EXSTYLE, rtn
'    SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA
'End Sub

'代码二: 形状不规则的窗体
Private Sub Form_Load()
    Dim rtn As Long
    BorderStyler = 0
    rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
    rtn = rtn Or WS_EX_LAYERED
    SetWindowLong hwnd, GWL_EXSTYLE, rtn
    
    '将扣去窗口中的蓝色(&HFF0000),你可以将要保留的部分改成非(&HFF0000)颜色值,当然你也可以用其它颜色
    '做成BMP位图,加载进来更容易,做个皮肤什么的....
    '(之前Print几个打字上面试试看)
    Me.BackColor = &HFF0000    
    PrintFont "哈哈哈"    
    SetLayeredWindowAttributes hwnd, &HFF0000, 0, LWA_COLORKEY
End Sub

Sub PrintFont(str As String)
    FontSize = 80
    FontName = "黑体"
    Print str
End Sub


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

监视某过程总耗时

'获取系统时钟API
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Sub TestLoop()
    Dim BeginTime As Long
    '记录开始时间
    BeginTime = timeGetTime()
    
    '过程
    Dim l As Long
    Do While l < 50000000
        l = l + 1
    Loop
    
    '回显
    Debug.Print "耗时(毫秒):", timeGetTime - BeginTime
End Sub


Private Sub Command1_Click()
    TestLoop
End Sub


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

'取得文件的8.3文件名,和初识Command(带参数运行EXE,参数的取得)
'生成EXE文件,然后将一个长文件名的文件图标拖到新生成的EXE文件上去.
'点击EXE文件的按钮,就可以看到转换结果了
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
        (ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
        ByVal cchBuffer As Long) As Long

Dim DOSFileName As String '声明dos 文件名
Dim LongFileName As String '声明长文件名
    
Private Sub Command1_Click()
    Text1.Text = GetShortFileName(DOSFileName)  '文件的短文件名
    Text2.Text = LongFileName   ''文件的长文件名
End Sub

Private Sub Form_Load()
    DOSFileName = Command$() '从命令行取得参数
    
    If Len(DOSFileName) > 0 Then MsgBox "Command参数:" & DOSFileName
    
    LongFileName = Dir(DOSFileName) '得到长文件名
End Sub

Public Function GetShortFileName(ByVal FileName As String) As String
    Dim l As Long
    Dim ShortPath As String
    Const PATH_LEN& = 164
    
    '获得文件的短文件名(包含路径)
    ShortPath = String(PATH_LEN + 1, 0)
    l = GetShortPathName(FileName, ShortPath, PATH_LEN)
    GetShortFileName = Left(ShortPath, l)
End Function


'自从进入Win95时代以来,Win95的长文件名给人们带来了很多方便,
'但是由于原来的DOS只支持8.3格式,即8个主文件名加上3个扩展名,
'所以所有Win95的长文件名都有一个DOS名,具体方法为取原长文件名前6位加～num(其中num为现目录中不重名的序号).
'现在的VB已完全支持了长文件名,但是有一点可能没有注意到,
'即当用Command()接收从命令行传来的参数时,如果参数是长文件名,则被强制转换成为DOS名,即8.3格式文件名.
'由于这两种文件名通用,所以一般情况下不会有什么问题.
'但遇到特殊场合就不行了.
'有没有办法再把8.3格式的文件名转换为原来的长文件名呢?答案是:可以。

如下内容,保存为*.bat(批处理)于同目录下,然后运行看看,呵呵
: 注:test.exe为上面代码生成的."kxufeng@163.com /s"随便写几个字符吧
test.exe kxufeng@163.com /s
---------------------------------------------------------------

'确定是 Windows 的可执行文件
'在文件的第 24 字节，如果为40H，就是 Windows 的可执行文件。

Function WinExeIs(ByVal EXEName As String) As Boolean
    'EXEName:文件名(含路径)
    
    '没有输入,跳到陷阱
    On Error GoTo NullErr
    '没有此文件,退出
    If Dir(EXEName) = "" Then MsgBox "没有这个文件!", vbInformation: Exit Function
    
    Dim i As Integer
    Dim s As String * 1
    i = FreeFile
    Open EXEName For Binary As #i
    '找24字节
    Get i, 25, s
    Close #i
    WinExeIs = (Asc(s) = &H40&)
    
    Exit Function
NullErr:
    
End Function

Private Sub Command1_Click()
    Dim s As String
    s = App.Path & "\form1.frm"     '一个要测试的文件
    MsgBox IIf(WinExeIs(s), "是", "不是") & "Windows可运行的文件", vbInformation
End Sub


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

调用Word7拼写检查和统计
'先引用"Microsoft Word 8.0 Object Library"或更高
Option Explicit

Dim Doc As New Document
Dim Visi As Boolean

'调用Word 97拼写检查
Private Sub Command1_Click()
    Form1.Caption = "拼写检查"
    Doc.Range.Text = Text1    '确定范围
    Doc.Application.Visible = True    '将Word 97变为可见
    AppActivate Doc.Application.Caption    '激活Word 97
    Doc.Range.CheckSpelling    '拼写检查

    Text1 = Doc.Range.Text
    Text1 = Left(Text1, Len(Text1) - 1)
    AppActivate Caption
End Sub

'统计单词数
Private Sub Command2_Click()
    Dim Dlg As Word.Dialog

    Doc.Range = Text1.Text
    Set Dlg = Doc.Application.Dialogs(wdDialogDocumentStatistics)
    Dlg.Execute    '统计单词和字符
    Form1.Caption = "单词数:" & Str(Dlg.Words) & "词" & Str(Dlg.Characters) & "字符"        '显示统计结果
End Sub

Private Sub Form_Load()
    Form1.Caption = "调用Word"
    Text1.Text = "Good good study, Day day up. Shit! English? Chinese?"
    Command1.Caption = "拼写检查"
    Command2.Caption = "统计单词"
    Visi = Doc.Application.Visible    '使应用程序可见
End Sub

'关闭应用程序
Private Sub Form_Unload(Cancel As Integer)
    If Visi Then '关闭文件
        Doc.Close savechanges:=False
    Else
        Doc.Application.Quit savechanges:=False '关闭Word 97
    End If
End Sub

樓主辛苦了
好東東
收藏先

调用系统文件拷贝对话框

Option Explicit

Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
        (lpFileOp As SHFILEOPSTRUCT) As Long
Const FO_COPY = &H2
Const FOF_ALLOWUNDO = &H40

Private Sub ShellCopyFile(SourceFiles As String, DestFiles As String)
    On Error Resume Next
    
    Dim Result As Long
    Dim Fileop As SHFILEOPSTRUCT
    With Fileop
        .hwnd = 0
        .wFunc = FO_COPY
        '拷贝一个文件
        .pFrom = SourceFiles & vbNullChar & vbNullChar
        '拷贝目录下所有文件
        '.pFrom = "C:\*.*" & vbNullChar & vbNullChar
        .pTo = DestFiles & vbNullChar & vbNullChar
        .fFlags = FOF_ALLOWUNDO
    End With
    Result = SHFileOperation(Fileop)
    If Result = 0 And Fileop.fAnyOperationsAborted <> 0 Then
        MsgBox "操作失败!", vbCritical Or vbOKOnly
    End If
End Sub

Private Sub Command1_Click()
    '如果文件够大(要超过几秒钟),才能看见对话框
    '或者连续两次按键,看看"是否替换"对话框
    ShellCopyFile App.Path & "\temp.txt", "c:\"
End Sub

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

'压缩路径名.什么意思?
'C:\Documents and Settings\Administrator\My Documents\temp.txt  压缩成:
'C:\Doc...\temp.txt
'很多地方都见过的:在一个有限的空间显示过长的路径名.


Private Declare Function PathCompactPath Lib "shlwapi" Alias "PathCompactPathA" _
        (ByVal hDC As Long, ByVal lpszPath As String, ByVal dx As Long) As Long

'三个参数:
'hDC:设备hDC
'lpszPath:文件地址字符串
'dx:宽度(象素)

Private Sub Command1_Click()
    Dim lhDC As Long, lWidth As Long
    Dim strLongFileName As String
    
    lhDC = Me.hDC
    
    '搞一个超常的地址,长度要大于Label1.Width,不然效果没的看了
    'strLongFileName = "C:\Abc\LALA\900\haha\longlong\A\003\TXT\123.txt"
    
    '通常"我的文档"的路径都很长,这里就拿它做测试(MyDocumentsDir函数见模块)
    strLongFileName = MyDocumentsDir(Me)
    strLongFileName = strLongFileName & "\temp.txt"
    
    '设置刻度为象素
    Me.ScaleMode = vbPixels
    '得到需要压缩的长度
    lWidth = Label1.Width - Me.DrawWidth
    '调用函数,返回新的strLongFileName
    PathCompactPath lhDC, strLongFileName, lWidth
    '显示
    Label1.Caption = strLongFileName
End Sub

'附模块代码:关于获取"我的文档"路径
Option Explicit

'获得我的文档路径
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


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

'去掉固定长度字符串右边的Null字符(ASCII值为0)和SPACE字符(ASCII值为32)
'解决一些函数的返回值是260字节长度,首尾部要跟一堆空字符

Public Function PurString(str As String) As String
    '去除Null字符
    'On Error Resume Next
    Dim i As Integer
    For i = 1 To Len(str)
        '过滤Null字符
        If Asc(Mid(str, i, 1)) <> 0 Then PurString = PurString & Mid(str, i, 1)
    Next
    '去除首尾空格
    PurString = Trim(PurString)
    
    '这样也行(不过,要先判断Null字符在左还是在右):
    'PurString = Left(str, InStr(str, Chr(0)) - 1)
End Function

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

避免 Null 产生的错误 

当我们从数据库读出数据时，有的字段内容可能为 Null，若不加以处理而要将数据赋值给某一字段时，会有错误产生，虽然 VB 本身有提供一个 IsNull 函数以供判断，但是您知道吗，我写了这么多年的 VB 数据库程序，从来没有用过 IsNull 来判断数据库字段值，为什么呢？我又怎么做呢？

其实很简单，我不管从数据库读出来的是不是 Null，写法一律如下：
Text1.Text = adoRS("Field1") & ""

如果这个字段的值是 Null，加上 (&"") 之后就变成了 "" 了！

但是要小心，我的新同事们常常会犯一个错误，我们看看以下二个式子：
1、Text1.Text = Trim(adoRS("Field1")) & ""    '(可能是错的)
2、Text1.Text = Trim(adoRS("Field1") & "")    '(这样写才对)

第一个式子如果字段值是 Null，使用 Trim$ 便会产生错误，对于这些状况，其实只要记住一个原则即可：
不管从数据库读出之资料要做什么动作，不管三七二十一先加上 (&"") 就对了

再来看看一个例子，以加深印象：
Text1.Text = Format( (adoRS("Field1") & ""), "yymmdd")


另有:
在往SQL Server数据库中添加记录时，每个字段必须给予明确赋值（即在没有给数据表设定缺省规则或给每个字段设定缺省值的情况下），否则便发生错误。因此我用VB编写了一个处理函数，将其放入标准模块，以供相应程序调用。函数首先判断是否给字段赋值，若没有，则根据字段类型的不同赋予不同数值（数字赋零，字符赋空格）

Function NoNull(FieldVar As Variant) As Variant
    If IsNull(FieldVar) Then
        '字段没有赋值，判断其类型
        If FieldVar.Type = 12 Then
            '字符型字段，赋空格
            NoNull = " "
        Else
            '数字型字段，赋0
            NoNull = 0
        End If
    Else
        NoNull = FieldVar
    End If
End Function

'VB处理数据库时求数据表记录总数的最佳方法

'rs 是一个 Recordset
'打开数据库,读取数据到rs代码略

Debug.Print rs.RecordCount
'此行代码的目的就是求出该表中的记录的总数.
'此处用到的是"表"对象的RecordCount属性,这样用在一般性况下是正确的,但并不能保证在所有的情况下都能得出正确的结果.
'比如说表中的数据量很大,或者是数据库受到过什么损害等等.
'如果碰到这种情况,我们可以换用下面的程序:

Dim Num As Long
Num = 0
rs.MoveFirst
Do While Not rs.EOF()
    Num = Num + 1
    rs.MoveNext
Loop
Debug.Print Num
'这样,最后得到的Num即为正解结果,这种方法的思路是从表的开始处一直顺序走到结尾,
'就可以"数"出表中到底有多少条记录.这种方法看起来很笨,但是它却是一个相当准确的方法,大家不防可以试一下.

'先看上面一行程序：Debug.Print rs.RecordCount,VB5在读取数据表时并非一次性将全部记录均读入内存
'想想看如果有一个表,里面有一百万个记录甚至一亿个或更多,要想全部读入内存,你的机器能承受得了吗.
'只是先读入一部分(在下认为这是VB的优异这处),recordset对象并非表的全部记录,只是已读入内存的部分,
'故用rs.recordcount得到的不是表的记录总数.

'再看上面第二段程序：
'在下用十万个记录的表对上面这段程序做了个测试,结果花了N分钟,如此的等待很不现实,请看在下的对策：

rs.Recordset.MoveLast '将指针移到表的最后一笔记录
Debug.Print rs.Recordset.RecordCount
'即可得出正确结果!
'或者
rs.Recordset.MoveLast
Debug.Print rs.Recordset.AbsolutePosition + 1
'调用绝对位置,因vb的第一笔记录是由0零算起,故要+1.

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

0、""(空字串)、Null、Empty、与 Nothing 的区别 
先回答以下问题吧！ 经过以下的叙述之后， 变量 A、B、C、D 分别等于 0、
""、Null、 Empty、 Nothing 的哪一个？
Dim A
Dim B As String
Dim C As Integer
Dim D As Object
A 等于 Empty， 因为尚未初始化的「不定型变量」都等于 Empty。但如果检
测 A = "" 或 A = 0， 也都可以得到 True 值。
B 等于 ""， 因为尚未初始化的非固定长度「字串」都等于 "" 。 但请注意 
B<> Null。
C 等于 0， 这个还有问题吗？
D 等于 Nothing， 尚未设定有物件的「物件变量」都等于 Nothing， 但请不
要使用 D = Nothing , 而要使用 D Is Nothing 来判断 D 是否等于 Nothing， 
因为判断 是否相等的符号是 Is 不是 = 。
最令人迷惑的地方是 Null 这个保留字， 请看以下语句：
Print X = Null
Print X <> Null
结果都是输出 Null(不是 True 也不是 False)， 这是因为任何一个运算式只
要含有 Null ， 则该运算式就等于 Null， 实际上想要判断某一数据是否为 Null 
绝对不能使用：
If X = Null Then ' 永远都会得到 Null
而要使用：
If IsNull(X) Then
哪一种数据会等于 Null 呢？ 除了含有 Null 运算式之外， 就属没有输入任
何数据的「数据字段」(在数据库中) 会等于 Null。


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

'keybd_event函数的使用
'下面的函数可以利用kb_event实行一些系统操作
Private Declare Sub keybd_event Lib "user32" _
        (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_LWIN = &H5B
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_APPS = &H5D
Private Const VK_PLAY = &HFA

Private Sub DoAction(Index As Integer)
    Dim VK_ACTION As Long

    Select Case Index
        Case 0: '打开资源管理器
            VK_ACTION = &H45
        Case 1: '查找文件
            VK_ACTION = &H46
        Case 2: '最小化所有窗口
            VK_ACTION = &H4D
        Case 3: '运行程序
            VK_ACTION = &H52
        Case 4: '弹出Win菜单
            VK_ACTION = &H5B
        Case 5: '将计算机转如睡眠状态
            VK_ACTION = &H5E
        Case 6: '执行Windows帮助
            VK_ACTION = &H70
    End Select
    
    Call keybd_event(VK_LWIN, 0, 0, 0)
    Call keybd_event(VK_ACTION, 0, 0, 0)
    Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
End Sub

Private Sub Command1_Click()
    Static i As Integer
    i = i + 1
    DoAction i
End Sub

图片到mdb数据库的存取
'Module Code:
Option Explicit

Public adoRS As Recordset
Public db As Connection

'先引用 Microsoft ActiveX Data Object 2.6 或更高版本
'csdngoodnight(Email:kxufeng@163.com)
Public Sub PicInMdb(objPictureBox As PictureBox)
    '将图片写数据库
    'objPictureBox: PictureBox图片容器
    
    '将 PictureBox 的图片保存为临时文件
    Dim TempFileName As String
    TempFileName = App.Path & "\pic.tmp"
    SavePicture objPictureBox.Image, TempFileName
    
    On Error GoTo mdbErr
    
    Dim Pic_Stream As New ADODB.Stream
    Pic_Stream.Type = adTypeBinary         '类型为二进制数组
    Pic_Stream.Open
    Pic_Stream.LoadFromFile TempFileName    '图片路径
    
    'adoRS.AddNew
    '"PictureOLE": Access数据库的字段(数据类型:OLE 对象)
    adoRS.Fields("PictureOLE").Value = Pic_Stream.Read
    adoRS.Update
    
    Kill TempFileName   '删除临时文件
    
    '关闭记录集
    adoRS.Close
    Exit Sub
mdbErr:
    MsgBox Err.Description, vbOKOnly + vbExclamation, "出错提示"
End Sub

Public Sub MdbOutPic(objPictureBox As PictureBox)
    '从数据库中提取二进制图片数据
    'objPictureBox: PictureBox图片容器
    
    Dim TempFileName As String
    TempFileName = App.Path & "\pic.tmp"
    
    On Error GoTo mdbErr
    
    Dim Pic_Stream As New ADODB.Stream
    Pic_Stream.Type = adTypeBinary
    Pic_Stream.Open
    Pic_Stream.Write adoRS.Fields("PictureOLE").Value
    Pic_Stream.SaveToFile TempFileName, adSaveCreateOverWrite  '保存临时图片文件
    objPictureBox.Picture = LoadPicture(TempFileName)    '控件加载
    
    Kill TempFileName      '删除临时文件
    
    '关闭记录集
    adoRS.Close
    Exit Sub
mdbErr:
    MsgBox Err.Description, vbOKOnly + vbExclamation, "出错提示"
End Sub


【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "将图片写数据库"
   ClientHeight    =   6720
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   6810
   LinkTopic       =   "Form1"
   ScaleHeight     =   6720
   ScaleWidth      =   6810
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command5 
      Caption         =   "打上这个烙印"
      Height          =   495
      Left            =   1800
      TabIndex        =   6
      Top             =   5640
      Width           =   1575
   End
   Begin VB.CommandButton Command4 
      Caption         =   "清除图片"
      Height          =   495
      Left            =   3960
      TabIndex        =   5
      Top             =   4440
      Width           =   1575
   End
   Begin VB.CommandButton Command3 
      Caption         =   "提取图片"
      Height          =   495
      Left            =   3960
      TabIndex        =   4
      Top             =   3840
      Width           =   1575
   End
   Begin VB.PictureBox Picture2 
      AutoSize        =   -1  'True
      Height          =   3060
      Left            =   3480
      ScaleHeight     =   3000
      ScaleWidth      =   2445
      TabIndex        =   3
      Top             =   600
      Width           =   2505
   End
   Begin VB.CommandButton Command2 
      Caption         =   "保存到数据库"
      Height          =   495
      Left            =   1080
      TabIndex        =   2
      Top             =   4440
      Width           =   1575
   End
   Begin VB.CommandButton Command1 
      Caption         =   "载入图片"
      Height          =   495
      Left            =   1080
      TabIndex        =   1
      Top             =   3840
      Width           =   1575
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      Height          =   3060
      Left            =   600
      ScaleHeight     =   3000
      ScaleWidth      =   2445
      TabIndex        =   0
      Top             =   600
      Width           =   2505
   End
   Begin VB.Image Image1 
      Height          =   720
      Left            =   960
      Picture         =   "Form1.frx":0000
      Top             =   5520
      Width           =   720
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command1_Click()
    Picture1.Picture = LoadPicture(App.Path & "\Hitomi.jpg")
End Sub

Private Sub Command2_Click()
    '写入图片
    '打开表(表名:Picture,两个字段:ID/主键;PictureOLE/数据类型OLE对象)
    adoRS.Open "SELECT * FROM Picture WHERE ID=22", db, adOpenStatic, adLockOptimistic
    
    PicInMdb Picture1
End Sub

Private Sub Command3_Click()
    '提取图片
    adoRS.Open "SELECT * FROM Picture WHERE ID=22", db, adOpenStatic, adLockOptimistic
    
    MdbOutPic Picture2
End Sub

Private Sub Command4_Click()
    Picture1.Picture = LoadPicture("")
    Picture2.Picture = LoadPicture("")
End Sub

Private Sub Command5_Click()
    '为了看效果,可以弄个烙印在上面(Image1是个图标)
    Picture1.PaintPicture Image1.Picture, 30, 30, Image1.Width, Image1.Height
End Sub

Private Sub Form_Load()
    On Error Resume Next
    Set db = New Connection
    db.CursorLocation = adUseClient
    '打开数据库(mdb名:Test.mdb)
    db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;" & _
        "Data Source=" & App.Path & "\Test.mdb;Jet OLEDB:" 'Database Password=1234;"
    Set adoRS = New Recordset
    
    Picture1.AutoRedraw = True
    Picture1.AutoRedraw = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error GoTo NotState
    'On Error Resume Next
    Debug.Print "adoRS.State", adoRS.State
    '如果处于打开状态,先关闭
    If adoRS.State = adStateOpen Then adoRS.Close
    Set adoRS = Nothing
    
    Debug.Print "db.State", db.State
    '如果处于打开状态,先关闭
    If db.State = adStateOpen Then db.Close
    Set db = Nothing
    
NotState:
    Debug.Print Err.Description
End Sub


【Project Code:将下面代码用记事本保存为 工程1.vbp(VB工程文件),此括弧及括弧内容除外】
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation
Reference=*\G{00000206-0000-0010-8000-00AA006D2EA4}#2.6#0#C:\Program Files\Common Files\system\ado\msado26.tlb#Microsoft ActiveX Data Objects 2.6 Library
Form=Form1.frm
Module=Module1; Module1.bas
Startup="Form1"
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



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



ADO语句+mdb,得到文件中所有的表及类型

    Dim rs As New Recordset
    'db是一个Connection,这里已经连接(代码略)
    Set rs = db.OpenSchema(adSchemaTables)
    Do Until rs.EOF
        Debug.Print "表名: " & rs!TABLE_NAME & vbCrLf & _
                    "表类型: " & rs!TABLE_TYPE & vbCrLf
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing

'各种进制的转换(演示)

Private Function TenTurnTwo(ByVal lNumber As Long) As String
    '10 to 2
    Dim i As Integer
    Do While lNumber > 0
        i = lNumber Mod 2
        lNumber = lNumber \ 2
        TenTurnTwo = Trim(Str(i)) + TenTurnTwo
    Loop
End Function

Private Function TwoTurnTen(ByVal varString As String) As Long
    '2 to 10
    Dim l As Long, i As Long
    l = Len(varString)
    For i = 0 To l - 1
        TwoTurnTen = TwoTurnTen + Val(Mid(varString, i + 1, 1)) * (2 ^ (l - i - 1))
    Next
End Function

Private Sub Command1_Click()    '10 to 2
    Dim l As Long
    l = CLng(Text1.Text)
    Text2.Text = TenTurnTwo(l)
End Sub

Private Sub Command2_Click()    '2 to 10
    Dim varString As String
    varString = Text2.Text
    Text1.Text = TwoTurnTen(varString)
End Sub

Private Sub Command3_Click()    '10 to 16
    '十进制转换到十六进制,函数:Hex()
    '然后前置 &H
    Dim l As Long
    l = CLng(Text1.Text)
    Text3.Text = "&H" & Hex(l)
End Sub

Private Sub Command4_Click()    '10 to 8
    '十进制转换到八进制,函数:Oct()
    '然后前置 &0
    Dim l As Long
    l = CLng(Text1.Text)
    Text4.Text = "&0" & Oct(l)
End Sub

Private Sub Command5_Click()    '16 to 2
    Dim l As Long
    l = CLng(Text3.Text)
    Text5.Text = TenTurnTwo(l)
End Sub

Private Sub Command6_Click()    '8 to 2
    Dim l As Long
    l = CLng(Text4.Text)
    Text6.Text = TenTurnTwo(l)
End Sub


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

'取得 DOS 环境变量,使用 Environ 函数
Private Sub Command1_Click()
    Dim x As Integer
    Dim Env As String
    x = 1
    Env = Environ(x)
    Do Until Env = ""
        Env = Environ(x)
        Debug.Print Env
        x = x + 1
    Loop
End Sub

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

'采用递归算法删除带有多级子目录的目录
Option Explicit

Private Sub Command1_Click()
    Dim strPathName As String
    '设置要删除的目录,此处设置为工作目录下的一个文件夹
    '(注:该目录将被彻底删除,即使是只读和系统属性的文件,而不是送到回收站,请设置到一个无用的目录上)
    strPathName = App.Path & "\aa"
    '出错则跳出
    If strPathName = "" Then Exit Sub
    
    On Error GoTo ErrorHandle
    SetAttr strPathName, vbNormal '此行主要是为了检查文件夹名称的有效性(设置目录属性到常规)
    '调用
    RecurseTree strPathName
    '返回后显示执行结果
    Label1.Caption = "文件夹" & strPathName & "已经删除！"
    Exit Sub
ErrorHandle:
    '陷阱
    MsgBox "无效的文件夹名称:" & strPathName
End Sub

Sub RecurseTree(CurrPath As String)
    Dim sFileName As String
    Dim sPath As String
    
    sPath = CurrPath & "\"
    
    '31的含义:31 = vbNormal + vbReadOnly + vbHidden + vbSystem + vbVolume + vbDirectory
    '即所有属性的目录
    sFileName = Dir(sPath, 31)
    '循环至没有目录
    Do While sFileName <> ""
        If sFileName <> "." And sFileName <> ".." Then
            If GetAttr(sPath & sFileName) And vbDirectory Then '如果是目录和文件夹
                '这里用到递归
                RecurseTree sPath & sFileName
                sFileName = Dir(sPath, 31)
            Else
                'SetAttr:设置文件属性
                SetAttr sPath & sFileName, vbNormal
                Kill (sPath & sFileName)
                Label1.Caption = sPath & sFileName '显示删除过程
                sFileName = Dir
            End If
        Else
            '退至父目录
            sFileName = Dir
        End If
        DoEvents
    Loop
    SetAttr CurrPath, vbNormal
    RmDir CurrPath
    Label1.Caption = CurrPath
End Sub

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

'读取文件的时间信息
'模块:
Const OFS_MAXPATHNAME = 128
Const OF_READ = &H0
Type OFSTRUCT
    cBytes As Byte
    fFixedDisk As Byte
    nErrCode As Integer
    Reserved1 As Integer
    Reserved2 As Integer
    szPathName(OFS_MAXPATHNAME) As Byte
End Type

Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Type FileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Type BY_HANDLE_FILE_INFORMATION
    dwFileAttributes As Long
    ftCreationTime As FileTime
    ftLastAccessTime As FileTime
    ftLastWriteTime As FileTime
    dwVolumeSerialNumber As Long
    nFileSizeHigh As Long
    nFileSizeLow As Long
    nNumberOfLinks As Long
    nFileIndexHigh As Long
    nFileIndexLow As Long
End Type

Type TIME_ZONE_INFORMATION
    bias As Long
    StandardName(32) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(32) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type


Declare Function GetTimeZoneInformation Lib "kernel32" _
        (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Declare Function OpenFile Lib "kernel32" _
        (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Declare Function GetFileInformationByHandle Lib "kernel32" _
        (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function FileTimeToSystemTime Lib "kernel32" _
        (lpFileTime As FileTime, lpSystemTime As SYSTEMTIME) As Long



Dim FileHandle As Long
Dim FileInfo As BY_HANDLE_FILE_INFORMATION
Dim lpReOpenBuff As OFSTRUCT, ft As SYSTEMTIME
Dim tZone As TIME_ZONE_INFORMATION

Dim dtCreate As Date ' 建立时间
Dim dtAccess As Date ' 存取日期
Dim dtWrite As Date ' 修改时间
Dim bias As Long

Public Function FileTimeZone(strFile As String)

    ' 先取得文件的 File Handle
    FileHandle = OpenFile(strFile, lpReOpenBuff, OF_READ)
    ' 利用 File Handle 读取文件信息
    Call GetFileInformationByHandle(FileHandle, FileInfo)
    Call CloseHandle(FileHandle)
    
    ' 读取 Time Zone 信息,因为上一步骤的档案时间是"格林威治"时间
    Call GetTimeZoneInformation(tZone)
    bias = tZone.bias ' 时间差,以"分钟"为单位
    
    Call FileTimeToSystemTime(FileInfo.ftCreationTime, ft) ' 转换时间资料结构
    dtCreate = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)
    Debug.Print "创建时间:", dtCreate
    
    Call FileTimeToSystemTime(FileInfo.ftLastAccessTime, ft)
    dtAccess = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)
    Debug.Print "存取时间:", dtAccess
    
    Call FileTimeToSystemTime(FileInfo.ftLastWriteTime, ft)
    dtWrite = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)
    Debug.Print "修改时间:", dtWrite

End Function


'调用: FileTimeZone "c:\abc.txt"


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


'获得IE的版本号
Private Type DllVersionInfo
    cbSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformID As Long
End Type

Private Declare Function DllGetVersion Lib "Shlwapi.dll" (dwVersion As DllVersionInfo) As Long

Private Function GetIEVersionString() As String
    Dim iever As DllVersionInfo
    
    iever.cbSize = Len(iever)
    Call DllGetVersion(iever)
    
    GetIEVersionString = "Internet Explorer " & iever.dwMajorVersion & "." & _
                         iever.dwMinorVersion & "." & iever.dwBuildNumber
End Function

Private Sub Command1_Click()
    Debug.Print GetIEVersionString
End Sub