对象是使用 TAB 键还是鼠标激活的
对象是使用 TAB 键还是鼠标激活的
声明：
Declare Function GetKeyState% Lib "User32" (ByVal nVirtKey%)
Const VK_TAB = 9
使用：
Sub Text1_GotFocus ()
If GetKeyState(VK_TAB) < 0 Then
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
' 使用了 TAB 键
Else
Text1.SelLength = 0
' 使用了 MOUSE
End If
End Sub

访问注册表
注册项(Registry)及用VB访问注册项

   在WINDOWS 3.X 下，各种系统和应用程序的有关状态信息都是以.INI文件的形式
存放的。而在WINDOWS 95/NT下，所有的状态信息都存放在操作系统所提供注册项
(Registry)中。通过对注册项的访问可以不仅实现对本地机的管理，也可以用网络注
册项工具进行网络诊断和管理。
   注册项文件是一个树形，以层次结构进行组织的数据库，它被分为两个文件进行
存储：一部分主要存放本机的系统设置等内容（通常是SYSTEM.DAT）；另一部分则主
要包含有关指定用户的信息（USER.DAT）。
   在WINDOWS NT中，注册项由四个子树组成：
HKEY_CLASSES_ROOT  包括软件配置信息，特别是对象链接与嵌入（OLE）和文件关联
  使用的信息（file association mappings）。
HKEY_USERS         存放所有本工作站上用户信息。包括工作站上的所有用户及用
  户的通用设置，如应用程序的缺省设置和桌面设置等。
HKEY_LOCAL_MACHINE  包括了对该工作站的指定信息（如硬件类型，端口映射，软件
   当前配置等）、驱动程序以及其它系统设置。
HKEY_CURRENT_USERS  包括用户当前登录到电脑上的有关信息，如对系统和程序的设
   置，其具体值在用户登录时根据HKEY_USER中相应记录创建。
   在WINDOWS 95中，除了上述四项以外，还有另外两项：
HKEY_CURRENT_CONFIG
HKEY_DYN_DATA
   分别存储工作站的当前硬件配置以及部分设备的动态状态，包括PNP。实际上，前
者的内容是HKEY_LOCAL_MACHINE的一个拷贝，而后者并不是注册项文件的一部分——
它是动态创建的。
   每个注册项子树下都有数个/层子键，每个子键都有一个或数个值，每个值项有三
部分：名称、数据类型和值本身。值的数据类型有：
REG_SZ 字符串
REG_DWORD 　 1-8个16进制数字的串
REG_BINARY 16进制数字的串，每对作为一个字节值解释

   在WINDOWS NT中，值的数据类型还有 REG_EXPAND_SZ 和 REG_MULTI_SZ，其中前
者与REG_SZ类似，但文本可包含可替换的变量；后者允许多个"值"，每个"值"作为
MULTI_SZ的成份。在WINDOWS 95中，数据类型还有REG_LINK。
   为了获得一个键的句柄（handle），用户必须从子树开始，遍历注册项树，直到
找到指定键。用户程序通常需要读写子树 HKEY_CURRENT_USER 以及
HKEY_LOCAL_MACHINE。如果指定键已存在，用户可以调用函数 RegOpenKey 或
RegOpenKeyEx； 如需要创建新的键，则调用RegCreateKey和RegCreateKeyEx。
   在获得键的句柄后，可以利用有关函数去列出、设置和修改键值。在所有情况下
，后缀带有Ex的函数只能工作在32位模式下，而后缀不带有Ex的函数则可以工作在16
位或32位工作模式下。注意：并不是所有的后缀无Ex的函数都对16位模式兼容。Ex后
缀仅表明该函数是在原有的 16位函数基础上的一种扩展。对于仅指定在 32位模式下
使用的函数并不带有Ex后缀。
   我们可以用RegSetValue和RegSetValueEx设置键值，但前者只允许一个键对应一
个键值，并且该键值的类型必须是REG_SZ；而后者则允许一个键有多个键值，并且键
值类型不受限制。
   下面介绍如何利用VB V4.0访问注册项。

　1、创建新的键
　下面这个函数调用RegCreateKeyEx在已定义的键的下一级创建一个新的键。

　Private Sub CreateNewKey (sNewKeyName As String, lPredefinedKey_  As Long)
      Dim hNewKey As Long         '新键的句柄
      Dim lRetVal As Long         'RegCreateKeyEx函数返回结果

      lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _
   vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, _
hNewKey, _lRetVal)
      RegCloseKey (hNewKey)   '关闭新键句柄
　End Sub

　　调用该函数：

  CreateNewKey "TestKey", HKEY_CURRENT_USER

　　这样，就在HKEY_CURRENT_USER下创建了一个名为“TestKey”的新键。

　　调用该函数：

     CreateNewKey "TestKey\SubKey1\SubKey2", HKEY_LOCAL_MACHINE

　　则在HKEY_CURRENT_USER下创建了以 TestKey 为首的三层嵌套的子键，其中
SubKey1 在TestKey之下, SubKey3在SubKey2之下。   

２、设置／修改键值
　　下面这个过程设置一个键的键值名称(name of the value)及数值、类型。对
于已存在的键名，可指定一个新值以改变当前值。

Private Sub SetKeyValue(sKeyName As String, sValueName As String,_
  vValueSetting As Variant, lValueType As Long)
      Dim lRetVal As Long         'SetValueEx函数返回值
      Dim hKey As Long         '键的句柄

      '打开指定键
      lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
      lRetVal = SetValueEx(hKey, sValueName, lValueType, _
vValueSetting)
      RegCloseKey (hKey)
  End Sub

　　调用该函数：

  SetKeyValue "TestKey\SubKey1", "StringValue", "Hello", REG_SZ

　　则在HKEY_CURRENT_USER的子键  TestKey\SubKey1下建立了一个其类型为
REG_SZ, 名称为StringValue的新值，它的数值为"Hello"。
　　必须注意：如果子键"TestKey\SubKey1"不存在，RegOpenKeyEx将导致错误
，为避免这种情况，建议使用 RegCreateKeyEx 以获取键的句柄。对于一个已经
存在的键， 函数   RegCreateKeyEx将打开该键。

　　3、获取键值
　　过程QueryValue用来列出指定键的某个值。

Private Sub QueryValue (sKeyName As String, sValueName As String)
      Dim lRetVal As Long         'API函数返回值
      Dim hKey As Long         '键的句柄
      Dim vValue As Variant      '存放查询结果的变量

      lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
  KEY_ALL_ACCESS, hKey)
      lRetVal = QueryValueEx(hKey, sValueName, vValue)
      MsgBox vValue
      RegCloseKey (hKey)
End Sub

　　调用该函数：

  QueryValue "TestKey\SubKey1", "StringValue"

　　结果显示为TestKey\SubKey1下名为StringValue的当前值。
　　如果所查询的键值不存在，该函数将显示错误代码2——'ERROR_BADKEY'。

　　4、API函数及常量定义

Option Explicit

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const REG_OPTION_NON_VOLATILE = 0

Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
"RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA"(ByVal hKey As Long, ByVal lpValueName As String,_
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA"(ByVal hKey As Long, ByVal lpValueName As String,_
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long

　　5、设置和查询函数

Public Function SetValueEx(ByVal hKey As Long, sValueName As _
String, lType As Long, vValue As Variant) As Long
   Dim lValue As Long
   Dim sValue As String
   Select Case lType
   Case REG_SZ
       sValue = vValue
       SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
　　　　　　lType, sValue, Len(sValue))
   Case REG_DWORD
       lValue = vValue
       SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
lType, lValue, 4)
   End Select
End Function

Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
   Dim cch As Long
   Dim lrc As Long
   Dim lType As Long
   Dim lValue As Long
   Dim sValue As String

   On Error GoTo QueryValueExError

   ' Determine the size and type of data to be read
   lrc = RegQueryValueExNULL(lhKey,szValueName, 0&, lType, 0&, cch)
   If lrc <> ERROR_NONE Then Error 5

   Select Case lType
   ' For strings
   Case REG_SZ:
　sValue = String(cch, 0)
　lrc = RegQueryValueExString(lhKey, szValueName, 0&,_
lType, sValue, cch)
     If lrc = ERROR_NONE Then
      vValue = Left$(sValue, cch)
     Else
   　     vValue = Empty
     End If
   ' For DWORDS
   Case REG_DWORD:
　lrc = RegQueryValueExLong(lhKey, szValueName, 0&, _
lType, lValue, cch)
   　If lrc = ERROR_NONE Then vValue = lValue
   Case Else
     'all other data types not supported
     lrc = -1
   End Select

QueryValueExExit:
   QueryValueEx = lrc
   Exit Function
QueryValueExError:
   Resume QueryValueExExit
End Function

　　另外，有的时候，用户并不需要得到键值，而只关心某个指定的键或键值是
否存在，这时，可以用RegEnumKey，RegEnumKeyEx，和RegEnumValue进行检测。

                                      作者:ariel_cy@usa.net

放大和缩小图象的简单方法
放大和缩小图象的简单方法 98-7-14
把图象放到 Image 控件，设置属性 Stretch 为 True。好啦，只要改变 Image 的大小，图象就可以放大和缩小啦。

放一个Combo到Toolbar中
放一个Combo到Toolbar中
1. 放一个 ComboBox 到表单.
2. 放一个 Toolbar  在表单.
3. 增加下面的代码到 Form1 :

Private Sub Form_Load()
Dim btn As Button
Me.Show
Set btn = Toolbar1.Buttons.Add()
btn.Style = tbrSeparator
Set btn = Toolbar1.Buttons.Add()
btn.Style = tbrPlaceholder
btn.Key = "ComboBox"
btn.Width = 2000
With Combo1
.ZOrder 0
.Width = Toolbar1.Buttons("ComboBox").Width
.Top = Toolbar1.Buttons("ComboBox").Top
.Left = Toolbar1.Buttons("ComboBox").Left
End With
End Sub

改变 TreeView 的背景
改变 TreeView 的背景
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

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 GWL_STYLE = -16&
Private Const TVM_SETBKCOLOR = 4381&
Private Const TVM_GETBKCOLOR = 4383&
Private Const TVS_HASLINES = 2&

Dim frmlastForm As Form

Private Sub Form_Load()
Dim nodX As Node
Set nodX = TreeView1.Nodes.Add(, , "R", "Root")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4")
nodX.EnsureVisible
TreeView1.style = tvwTreelinesText ' Style 4.
TreeView1.BorderStyle = vbFixedSingle
End Sub

Private Sub Command1_Click()
Dim lngStyle As Long
Call SendMessage(TreeView1.hWnd, TVM_SETBKCOLOR, 0, ByVal RGB(255, 0, 0))
'改变背景到红色

lngStyle = GetWindowLong(TreeView1.hWnd, GWL_STYLE)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle - TVS_HASLINES)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle)
End Sub

改变墙纸
改变墙纸
声明：
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
用法：
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, BMP名称, SPIF_UPDATEINIFILE)
例子：
' 1. 把桌面图片设为 c:\windows\setup.bmp
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "c:\windows\setup.bmp", SPIF_UPDATEINIFILE)
' 2. 将桌面图片清除
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "", SPIF_UPDATEINIFILE)

格式化磁盘
格式化磁盘
在Drive的参数中 "A:" = 0，类推。

Private Const SHFMT_ID_DEFAULT = &HFFFF&
'Currently the only fmtID supported.

Private Declare Function SHFormatDrive Lib "shell32.dll" (ByVal hWnd As Long, ByVal Drive As Long, fmtID As Long, Options As Long) As Long

Private Sub Command1_Click()
Dim lret As Long
lret = SHFormatDrive(Me.hWnd, 0, SHFMT_ID_DEFAULT, 0)
Select Case lret
Case -2
MsgBox "OK !"
Case -3
MsgBox "Cannot format a read only drive !"
End Select
End Sub

混合字符串的长度
在中文环境下，每个字被当做两个 Byte ：
Len("汉1") = 2
LenB("汉1") = 4
但在许多情况下，我们希望中文字长度为 2，英文字符为 1。可用以下的函数：
LenB(StrConv("汉1"), vbFormUnicode))

获得用户网络登录名
获得用户网络登录名
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Function NTDomainUserName() As String
Dim strBuffer As String * 255
Dim lngBufferLength As Long
Dim lngRet As Long
Dim strTemp As String

lngBufferLength = 255
lngRet = GetUserName(strBuffer, lngBufferLength)
strTemp = UCase(Trim$(strBuffer))
NTDomainUserName = Left$(strTemp, Len(strTemp) - 1)

End Function

检测文件是否存在
检测文件是否存在
Function FileExists(FileName As String) As Boolean
   On Error Resume Next
   FileExists = Dir$(FileName) <> ""
   If Err.Number <> 0 Then
       FileExists = False
   End If
   On Error GoTo 0
End Function