假设有应用 myapp.exe 及一个注册文件 myapp.reg，下面的代码将自动装入注册设置。
Dim strFile As String
strFile = App.Path & "\myapp.reg"
If Len(Dir$(strFile)) > 1 Then
lngRet = Shell("Regedit.exe /s " & strFile, vbNormalFocus)
End If

确定当前 WIN95 的启动状态
定义：
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Const SM_CLEANBOOT = 67
使用：
Select Case GetSystemMetrics(SM_CLEANBOOT)
Case 1: MsgBox "在安全模式。"
Case 2: MsgBox "在带网络环境的安全模式。"
Case Else: MsgBox "正常模式。"
End Select
返回

声明：
Declare Function GetTickCount& Lib "kernel32" ()

使用该函数，可以得到从开机开时的运行时间，以 1/1000 秒记数。
返回

声明：
Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
增加字体：
Dim lResult As Long
lResult = AddFontResource("c:\myApp\myFont.ttf")
删除字体：
Dim lResult As Long
lResult = RemoveFontResource("c:\myApp\myFont.ttf")
返回

任务栏一般是显示在窗口的最底下，但有时我们需要隐藏它。
声明：
Dim hWnd1 As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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
Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40
隐藏的例子：
hWnd1 = FindWindow("Shell_traywnd", "")
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
显示的例子：
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)

退出并关闭 Windows
声明：
Global Const EWX_LOGOFF = 0
Global Const EWX_REBOOT = 2
Global Const EWX_SHUTDOWN = 1
Declare Function ExitWindows Lib "User32" Alias "ExitWindowsEx" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
使用：
lresult = ExitWindowsEx(EWX_SHUTDOWN, 0&) '关闭计算机
lresult = ExitWindowsEx(EWX_REBOOT, 0&) '重新启动计算机
参见： 文件下载中的 X020 模拟关闭系统
返回

最近用过的文件会自动出现在文档菜单中，只要用很少的代码，在你的程序中也可实现这样的功能：
声明：
Public Const SHARD_PATH = &H2&
Public Declare Function SHAddToRecentDocs Lib "shell32.dll" (ByVal dwFlags As Long, ByVal dwData As String) As Long
函数：
Public Sub AddRecent(strFile As String)
Dim lRetVal As Long
If strFile = "" Then
lRetVal = SHAddToRecentDocs(SHARD_PATH, vbNullString)
Else
lRetVal = SHAddToRecentDocs(SHARD_PATH, strFile)
End If
End Sub
例子：
AddRecent "C:\myfile.txt"
AddRecent "" '清除文档菜单
返回

声明：
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
例子：
Dim S As String * 80, Length As Long
Dim WinPath As String, SysPath As String
Length = GetWindowsDirectory(S, Len(S))
WinPath = Left(S, Length)
Length = GetSystemDirectory(S, Len(S))
SysPath = Left(S, Length)

WinPath 为 Windows 的所在目录，SysPath 为 System 所在目录。
返回

声明：
Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
例子：
Dim LocaleID As Long
LocalID = GetSystemDefaultLCID

= &H404 中文繁体（台湾）
= &H804 中文简体（大陆）
= &H409 英文 ...
返回

在进行重要的操作或特定的情况下，我们可能需要重新验证用户的口令，以提高系统的安全性。

Private Declare Function WNetVerifyPassword Lib "mpr.dll" Alias "WNetVerifyPasswordA" (ByVal lpszPassword As String, ByRef pfMatch As Long) As Long

Function VerifyPassWin95(sPassword As String) As Boolean
Dim lRetVal As Long
If (WNetVerifyPassword(sPassword, lRetVal)) <> 0 Then
MsgBox "VerifyPassWin95: Application Error"
Else
If lRetVal <> 0 Then
VerifyPassWin95 = True
Else
VerifyPassWin95 = False
End If
End If
End Function
返回

'get format of currency with API call GetLocalInfo
Public Const LOCALE_USER_DEFAULT = &H400
Public Const LOCALE_SCURRENCY = &H14 ' local monetary symbol
Public Const LOCALE_SINTLSYMBOL = &H15 ' intl monetary symbol
Public Const LOCALE_SMONDECIMALSEP = &H16 ' monetary decimal separator
Public Const LOCALE_SMONTHOUSANDSEP = &H17 ' monetary thousand separator
Public Const LOCALE_SMONGROUPING = &H18 ' monetary grouping
Public Const LOCALE_ICURRDIGITS = &H19 ' # local monetary digits

Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long


'
' Locale specific information
'
Public Sub GetInfo()
Dim buffer As String * 100
Dim dl&

'compare this with
'Start/Settings/Control Panel/Regional Settings/Currency

#If Win32 Then
dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SCURRENCY, buffer, 99)
Form1.list1.AddItem " Local curency symbol: " & LPSTRToVBString(buffer)
dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SINTLSYMBOL, buffer, 99)
Form1.list1.AddItem " International currency symbol: " & LPSTRToVBString(buffer)
dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SMONDECIMALSEP, buffer, 99)
Form1.list1.AddItem " Decimaal separator: " & LPSTRToVBString(buffer)
dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SMONTHOUSANDSEP, buffer, 99)
Form1.list1.AddItem " Thousand separator: " & LPSTRToVBString(buffer)
dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SMONGROUPING, buffer, 99)
Form1.list1.AddItem " Number of digits in group: " & LPSTRToVBString(buffer)
dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_ICURRDIGITS, buffer, 99)
Form1.list1.AddItem " Number of digits behind the decimal separator: " & LPSTRToVBString(buffer)
#Else
Form1.list1.AddItem " Not implemented under Win16"
#End If

End Sub


'
' Extracts a VB string from a buffer containing a null terminated
' string
Public Function LPSTRToVBString$(ByVal s$)
Dim nullpos&
nullpos& = InStr(s$, Chr$(0))
If nullpos > 0 Then
LPSTRToVBString = Left$(s$, nullpos - 1)
Else
LPSTRToVBString = ""
End If
End Function
返回

下面的函数演示如何获得某个文件夹下的所有子目录
Public Sub HaalDirOp(ByVal Path$)
Dim vDirName As String, LastDir As String

Screen.MousePointer = vbHourglass
If Right(Path$, 1) <> "\" Then Path$ = Path$ & "\"
vDirName = Dir(Path, vbDirectory) ' Retrieve the first entry.
Do While Not vDirName = ""
If vDirName <> "." And vDirName <> ".." Then
If (GetAttr(Path & vDirName) And vbDirectory) = vbDirectory Then
LastDir = vDirName

MsgBox vDirName

Call HaalDirOp(Path$ & vDirName)

vDirName = Dir(Path$, vbDirectory)
Do Until vDirName = LastDir Or vDirName = ""
vDirName = Dir
Loop
If vDirName = "" Then Exit Do
End If
End If
vDirName = Dir
Loop
Screen.MousePointer = vbNormal
End Sub
返回

Declare Function OSfCreateShellGroup Lib "STKIT432.DLL" Alias "fCreateShellFolder" _
(ByVal lpstrDirName As String) As Long

Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal _
lpstrFolderName As String, ByVal lpstrLinkName As String, _
ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long


'-----------------------------------------------------------
' SUB: CreateShellGroup
'
' Creates a new program group off of Start>Programs in the
' Windows 95 shell if the specified folder doesn't already exist.
'
' IN: [strFolderName] - text name of the folder.
' This parameter may not contain
' backslashes.
' ex: "My Application" - this creates
' the folder Start>Programs>My Application
'-----------------------------------------------------------
'
Public Sub CreateShellGroup(ByVal strFolderName As String)

If strFolderName = "" Then
Exit Sub
End If

Dim fSuccess As Boolean
fSuccess = OSfCreateShellGroup(strFolderName)

End Sub


'use as

Dim res&
Dim vLocation$

vLocation$ = "testing"
Call CreateShellGroup(vLocation$)
vLocation$ = "..\..\Start Menu\Programs\" & vLocation$
res& = fCreateShellLink(vLocation, [title], [path&executable], "")

'where
' title = name to be mentioned
' path&executable = full path and executable name of application
返回

1. 建立一个新的工程文件。

2. 将一个CommandButton (Name属性设置为 cmdForceShutdown) 加入到 Form1。

3. 将下面的代码加入到Form1的 General Declarations 段:

Option Explicit

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

' Beginning of Code
Private Const EWX_SHUTDOWN As Long = 1
Private Const EWX_FORCE As Long = 4
Private Const EWX_REBOOT = 2

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
Private Sub AdjustToken()

Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Dim hdlProcessHandle As Long
Dim hdlTokenHandle As Long
Dim tmpLuid As LUID
Dim tkp As TOKEN_PRIVILEGES
Dim tkpNewButIgnored As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long

hdlProcessHandle = GetCurrentProcess()
OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_QUERY), hdlTokenHandle

' Get the LUID for shutdown privilege.
LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid

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

' Enable the shutdown privilege in the access token of this
' process.
AdjustTokenPrivileges hdlTokenHandle, False, tkp, _
Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded

End Sub

Private Sub cmdForceShutdown_Click()
AdjustToken
ExitWindowsEx (EWX_SHUTDOWN Or EWX_FORCE Or EWX_REBOOT), &HFFFF
End Sub

返回

    在Windows系统中包含了一些图标，这些图标用于在系统消息框中显示一些提示，例如惊叹号图标等。，这个技巧介绍了如何在VB程序中利用这些图标。
    这些系统图标的定义如下：

    Const IDI_APPLICATION = 32512&
    Const IDI_HAND = 32513&
    Const IDI_QUESTION = 32514&
    Const IDI_EXCLAMATION = 32515&
    Const IDI_ASTERISK = 32516&

    在在VB中使用这些图标之前，你需要首先利用Windows API函数LoadIcon将图标载如到需要显示图标的对象的绘图设备中，利用Windows API函数GetWindowDC可以获得一个对象（例如PictureBox等）的图形绘图设备句柄。GetWindowsDC的定义如下:

    Private Declare Function GetWindowDC Lib "User" (ByVal hWnd As Integer)As Integer
    (注：如果上面的函数定义在你的浏览器中显示为两行或以上，则在你的程序中必须书写在一行以内）
    上面的函数中的参数hWnd指定了需要获得绘图设备句柄的对象的窗口，如果函数调用成功的话，函数将返回对象的绘图句柄，否则将返回0。
    当你不在需要使用绘图设备时，需要调用Windows API函数ReleaseDC来释放绘图设备句柄。
    当获得了绘图谁被句柄之后，你可以调用LoadIcon函数来在绘图设备上显示图标了。因为这些图标是系统内建的，所以我们需要将LoadIcon函数的第一个参数的值设置为0，而第二个参数需定义为上面定义的图标常量。
    范例
    1. 在VB中建立一个新的工程文件。
    2. 将下面的代码加入到form1的代码窗口中（注意没一个定义必须书写在一行之内）:

Private Declare Function DrawIcon Lib "User" (ByVal hDC As Integer, ByVal X As Integer, ByVal y As Integer, ByVal hIcon As Integer) As Integer
Private Declare Function LoadIcon Lib "User" (ByVal hInstance As Integer, ByVal lpIconName As Any) As Integer
Private Declare Function GetWindowDC Lib "User" (ByVal hWnd As Integer) As Integer
Private Declare Function ReleaseDC Lib "User" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
Const IDI_EXCLAMATION = 32515&

3. 在Form1中加入一个PictureBox控件，将它的AutoRedraw 属性设置为 True。
4. 在Form1中加入一个CommandButton控件。
5. 将下面的代码加入到Command1的Click事件中：

Private Sub Command1_Click()
Dim hDCCur As Long
Dim hIcon As Integer
Dim X As Integer

hDCCur = GetWindowDC(Picture1.hWnd)
hIcon = LoadIcon(0, IDI_EXCLAMATION)
X = DrawIcon(hDCCur, 0, 0, hIcon)
Call ReleaseDC(Picture1.hWnd, hDCCur)
End Sub
返回

Abstract
The Microsoft Visual Basic List Box control lets you add individual items to
create a list of data. This article explains how to add tab stops to create
multicolumn items, no matter what type of font or font size is used.

Using the GetDialogBaseUnits Function
When adding items to a List Box control, you can create columns of data by
inserting a tab stop within the control. However, the data will only be correctly
aligned in the columns if you use the default font and font size used by the List
Box control.

As the example program below shows, you can use the Microsoft Windows俺
application programming interface (API) GetDialogBaseUnits function to determine
the width and height of the average character in the selected font. The width and
height of the character are returned in dialog base units. From these values, you
can calculate the average width of the characters in the selected font.
After you know the width of the character set, you can add the tab stops to the
List Box control. Then, using whatever font and font size you want, you can add
new items to the control. The columns of data will appear in separate rows.

Example Program
This program shows how to add tab stops to a List Box control. No matter what font
or font size is used when adding items to the control, the columns will line up
correctly.

1. Create a new project in Visual Basic. Form1 is created by default.
2. Add the following Constant and Declare statements to the General Declarations
section of Form1 (note that each Declare statement must be typed as a single
line of text):

Private Declare Function GetFocus Lib "user32" () As Long

Private Declare Function GetDialogBaseUnits 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 Declare Sub APISetFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long)

Const WM_USER = &H400
Const LB_SETTABSTOPS = WM_USER + 19
3. Add the following code to the Form_Load event for Form1:

Private Sub Form_Load()
Dim TB As String * 1
Dim OldHandle As Integer
Dim ListHandle As Integer
Dim DlgWidthUnits As Integer
Dim I As Integer
ReDim TabStop(2) As Integer

TabStop(0) = 10
TabStop(1) = 30
TabStop(2) = 50

TB = Chr$(9)
Show
OldHandle = Getfocus()

List1.SetFocus
ListHandle = Getfocus()
DlgWidthUnits = (GetDialogBaseUnits() Mod 65536) / 2

For I = 0 To 2
TabStop(I) = TabStop(I) * DlgWidthUnits
Next I

Call SendMessage(ListHandle, LB_SETTABSTOPS, 3, TabStop(0))
Call APISetFocus(OldHandle)
List1.AddItem "Item" + TB + "Quan." + TB + "Price"
List1.AddItem "Disks" + TB + "10" + TB + "$9.50"
List1.AddItem "Paper" + TB + "12" + TB + "$22.50"
End Sub

4. Add a List Box control to Form1. List1 is created by default.