VBAPI函数摸索

VBAPI函数摸索
-72:打开屏幕保护程序
Const WM_SYSCOMMAND = &H112&
Const WM_SCREENSAVE = &HF140&
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd _
As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'打开屏幕保护程序
Private Sub LockComputer()
Dim result As Long
result = SendMessage(Form1.hWnd, WM_SYSCOMMAND, WM_SCREENSAVE, 0&)
End Sub
-71:设置指定矩形的位置
SetRect
VB声明
Declare Function SetRect Lib "user32" Alias "SetRect" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
说明
设置指定矩形的内容
返回值
Long，非零表示成功，零表示失败。

会设置GetLastError
参数表
参数类型及说明
lpRect RECT，欲设置的矩形
X1 Long，左侧区域（Left）的值
Y1 Long，顶部区域（Top）的值
X2 Long，右侧区域（Right）的值
Y2 Long，底部区域（Bottom）的值
例子：
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim r As RECT
Private Sub main()
SetRect r, 0, 0, 344, 344
ClipCursor r
End Sub
-70:改变指定窗口（包括文本框等）位置和大小
改变指定窗口的位置和大小。

顶级窗口可能受最大或最小尺寸的限制，那些尺寸优先于这里设置的参数
返回值
Long，非零表示成功，零表示失败
参数表
参数类型及说明
hwnd Long，欲移动窗口的句柄
x Long，窗口新的左侧位置
y Long，窗口新的顶部位置
nWidth Long，窗口的新宽度
nHeight Long，窗口的高宽度
bRepaint Long，如窗口此时应重画，则设为TRUE（非零）。

FALSE（零）则表明应用程序会自己决定是否重画窗口
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 Sub Command1_Click()
MoveWindow Text1.hwnd, 0, 8, 24, 24, 1
End Sub
-69:得到窗口矩形
GetWindowRect
Private Declare Function GetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hwnd As Long, lpRect As RECT) As Long Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim lprect as RECT
GetWindowRect Me.hwnd,lprect
此时窗口矩形已经装入变量 lprect
-68:控制音量
Private Declare Function waveOutSetVolume Lib "winmm.dll"(ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
Const WAVE_MAPPER = -1&
Const MMSYSERR_NOERROR = 0
Sub SetVolume()
Dim lV
ol As Long
lVol = CLng(HScroll2.Value) * &H100 Or HScroll1.Value
'设置音量
If waveOutSetVolume(WAVE_MAPPER, lVol) <> MMSYSERR_NOERROR Then
MsgBox "音量设置出错"
End If
End Sub
Private Sub Command1_Click()
SetVolume
End Sub
-67:开始菜单一打开就关闭,Windows 任务管理器同样如此
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Sub Timer1_Timer()
Dim hw As Long
hw = FindWindow(vbNullString, "Windows 任务管理器")
SendMessage hw, &H10, 0, 0
SendKeys "%"
Me.SetFocus
End Sub
-66:打开,关闭CD -ROM
一：
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long
Private Sub Command1_Click()
'以下是打开CD -ROM的过程代码:
retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)
End Sub
Private Sub Command2_Click()
'关闭CD -ROM用以下代码:
retvalue = mciSendString("set CDAudio door closed", returnstring, 127, 0)
End Sub
二：
Option Explicit
Private Declare Function CDdoor Lib "winmm.dll" Alias
"mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim state1 As Boolean
Private Sub Command1_Click()
'打开光驱
state1 = True
Call CDdoor("set CDAudio door open", 0, 0, 0)
End Sub
Private Sub Command2_Click()
'关闭光驱
state1 = False
Call CDdoor("set CDAudio door closed", 0, 0, 0)
End Sub
Private Sub Command3_Click()
End
End Sub
-65:出现关于的Form
一言难尽，试一试就知道这是什麽
Private Declare Function ShellAbout Lib "shell32.dll" Alias _
"ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, _
ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Sub command1_Click()
ShellAbout Me.hwnd, _
"我的程式", "1998.4.30 第一版", Me.Icon
End Sub
-64:调出[运行]对话框
Private Declare Function SHRunDialog Lib "Shell32" Alias "#61" (ByVal hOwner As Long, ByVal hIcon As Long, ByVal sDir As Long, ByVal szTitle As String, ByVal szPrompt As String, ByVal uFlags As Long) As Long
Dim uFlag As Long
SHRunDialog mhOwner, mhIcon, 0, mDialogTitle, mDialogPrompt, 0
-63:添加,删除,修改托盘图标
需要的声明:
Option Explicit
'声明Shell_NotifyIcon函数，用于将图标加入到系统托盘中
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pn
id As NOTIFYICONDATA) As Boolean
'声明自定义的数据类型NOTIFYICONDATA
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
'声明常量
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
要想当鼠标单击时显示自定义菜单的这样
'定义SetWindowLong，用以改变frmTemp窗体的窗体函数
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'定义事件的常数代码
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_USER = &H400
'定义自定义的事件WM_NOTIFYICON
Public Const WM_NOTIFYICON = WM_USER + &H100
'替换窗口处理函数
Public Const GWL_WNDPROC = (-4)
'调用SetWindowLong函数来改变frmTemp窗体的窗体函数
Call SetWindowLong(frmTemp.hwnd, GWL_WNDPROC, AddressOf DialogProc)
添加系统托盘图标:
Dim nid As NOTIFYICONDATA
nid.cbSize = Len(nid)
nid.hwnd = Me.hwnd
nid.uId = 1&
nid.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
nid.uCallbackMessage = WM_NOTIFYICON
nid.hicon = me.icon '可以换成别的如imgIcon.Picture
nid.szTip = "i love you" & Chr(0) '当鼠标放上去的时候显示的内容
'调用Shell_NotifyIcon函数将图标加入到系统托盘中Shell_NotifyIcon NIM_ADD, nid
修改系统托盘图标:
Dim nid As NOTIFYICONDATA
nid.cbSize = Len(nid)
nid.hwnd = Me.hwnd
nid.uId = 1&
nid.uFlags = NIF_ICON
nid.hicon = imgIcon.Picture
'调用Shell_NotifyIcon函数来修改系统托盘中的图标Shell_NotifyIcon NIM_MODIFY, nid
End Sub
删除系统托盘图标:
Dim nid As NOTIFYICONDATA
nid.cbSize = Len(nid)
nid.hwnd = frmTemp.hwnd
nid.uId = 1&
nid.uFlags = 0
'调用Shell_NotifyIcon方法来删除系统托盘中的图标Shell_NotifyIcon NIM_DELETE, nid
删除后,再添加系统托盘图标
Dim nid As NOTIFYICONDATA
nid.cbSize = Len(nid)
nid.hwnd = Me.hwnd
nid.uId = 1&
nid.uFlags = NIF_ICON
nid.hicon = imgIcon.Picture
Shell_NotifyIcon NIM_DELETE, nid
Shell_NotifyIcon NIM_ADD, nid
-62:如何截取屏幕画面
事实上，这是摸拟按下Print Screen的作法
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const theScreen = 1
Const theForm = 0
Private Sub Command1_Click()
Call keybd_event(vbKeySnapshot, theForm, 0, 0)
'若theForm改成theScreen则Copy整个Screen
DoEvents
Picture1.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
-60:获得windows启动模式
Private Declare
Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long
Const SM_CLEANBOOT = 67
Private Sub Command1_Click()
Select Case GetSystemMetrics(SM_CLEANBOOT) Case 1: Label1 = "安全模式."
Case 2: Label1 = "支持网络的安全模式."
Case Else: Label1 = "Windows运行在普通模式." End Select
End Sub
-59:关闭一个程序
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Const WM_CLOSE = &H10
Private Sub Form_Click()
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "我的电脑")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "发送消息错误."
End If
Else
MsgBox "我的电脑窗口不存在"
End If
End Sub
-58:MessageBeep 播放一个系统声音
VB声明
Declare Function MessageBeep Lib "user32" Alias "MessageBeep" (ByVal wType As Long) As Long
说明
播放一个系统声音。

系统声音的分配方案是在控制面板里决定的返回值
Long，非零表示成功，零表示失败。

参数表
参数类型及说明
wType Long，下述值之一
0xffffffff 标准响铃
MB_ICONASTERISK 系统星号声（System asterisk sound）
MB_ICONEXCLAMATION 系统惊叹声
MB_ICONHAND 系统指针声（System hand sound）
MB_ICONQUESTION 系统提问声
Top
-57:或取系统电池相关信息.
Private Declare Function GetSystemPowerStatus Lib "kernel32" (lpSystemPowerStatus As SYSTEM_POWER_STATUS) As Long
Private Type SYSTEM_POWER_STATUS
ACLineStatus As Byte '返回值为0，1，2；0代表没有接上电源适配器，即没有外接电源；1表示接上；2表示不知道；
BatteryFlag As Byte '表示电池电力高低情况
BatteryLifePercent As Byte '表示电量剩余百分之几；
Reserved1 As Byte
BatteryLifeTime As Long '表示剩余多少秒了
BatteryFullLifeTime As Long
End Type
Private Sub Form_Paint()
Dim SPS As SYSTEM_POWER_STATUS
GetSystemPowerStatus SPS
Me.AutoRedraw = True
Select Case SPS.ACLineStatus
Case 0
Me.Print "AC power status: Offline"
Case 1
Me.Print "AC power status: OnLine"
Case 2
Me.Print "AC power status: Unknown"
End Select
Select Case SPS.BatteryFlag
Case 1
Me.Print "Battery charge status: High"
Me.Print "Battery charge status: Low"
Case 4
Me.Print "Battery charge status: Critical"
Case 8
Me.Print "Battery charge status: Charging"
Case 128
Me.Print "Battery charge status: No system battery"
Case 255
Me.Print "Battery charge status: Unknown Status"
End Select
Print SPS.BatteryLifePercent; SPS.BatteryLifeTime; SPS.BatteryFullLifeTime; SPS.Reserved1
End Sub
注意:AC表示交流电源；DC表示稳压电源,即笔记本使用的电源；
-56:GetInputState函数
不断检测键盘和鼠标
Private Declare Function GetInputState Lib "user32" () As Long
Dim a As Integer
Private Sub Command1_Click()
Do Until a = 5
If GetInputState Then DoEvents
Loop
MsgBox "After loop..."
End Sub
Private Sub Command2_Click()
a = a + 1
End Sub
Private Sub Form_Load()
Command1.Caption = "Start loop"
Command2.Caption = "Stop loop"
End Sub
-55:
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Const MAX_FILENAME_LEN = 260
Private Sub Form_Load()
Dim i As Integer, s2 As String
Const sFile = "E:\天籁之音\beyond-光辉岁月.mp3"
s2 = String(MAX_FILENAME_LEN, 32)
i = FindExecutable(sFile, vbNullString, s2)
If i > 32 Then
MsgBox Left$(s2, InStr(s2, Chr$(0)) - 1)
Else
MsgBox "No association found !"
End If
Unload Me
End Sub
注意:如果找到对应文件的执行应用程序,则该函数返回值大于32,否则小于32.
-54:EqualRect函数判断两个矩形结构是否相同
VB声明
Declare Function EqualRect Lib "user32" Alias "EqualRect" (lpRect1 As RECT, lpRect2 As RECT) As Long
说明
判断两个矩形结构是否相同
返回值
Long，非零表示成功，零表示失败。

会设置GetLastError
参数表
参数类型及说明
lpRect1 RECT，要比较的矩形
lpRect2 RECT，要比较的矩形
Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Form_Load()
Dim p1 As RECT, p2 As RECT
p1.Left = Me.Left / Screen.TwipsPerPixelX
p1.Top = Me.Top / Screen.TwipsPerPixelY
p1.Right = (Me.Left + Me.Width) / Screen.TwipsPerPixelX
p1.Bottom = (Me.T op + Me.Height) / Screen.TwipsPerPixelY
p2.Left = Me.Left / Screen.TwipsPerPixelX
p2.Top = Me.Top / Screen.TwipsPerPixelY
p2.Right = (Me.Left + Me.Width) / Screen.TwipsPerPixelX
p2.Bottom = (Me.T op + Me.Height) / Screen.TwipsPerPixelY
Print EqualRect(p1, p2)
End Sub
-53:锁定鼠标
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()
DoEvents
'block the
mouse and keyboard input
BlockInput True
'wait 10 seconds before unblocking it
Sleep 10000
'unblock the mouse and keyboard input
BlockInput False
End Sub
-52:发声函数
Beep
VB声明
Declare Function Beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long 说明
用于生成简单的声音
返回值
Long，TRUE（非零）表示成功，否则返回零。

会设置
GetLastError
参数表
参数类型及说明
dwFreq Long，声音频率（从37Hz到32767Hz）。

在windows95中忽略
dwDuration Long，声音的持续时间，以毫秒为单位。

如为-1，表示一直播放声音，直到再次调用该函数为止。

在windows95中会被忽略
注解
在windows95中，这个函数简单的播放默认系统响铃
例如:
Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Sub Form_Activate()
Dim Cnt As Long
For Cnt = 0 To 5000 Step 10
'play a tone of 'Cnt' hertz, for 50 milliseconds
Beep Cnt, 50
Me.Caption = Cnt
DoEvents
Next Cnt
End Sub
-51:ShellExecute函数:找到文件的关联程序后,并用该程序运行该文件
发送电子邮件
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
Const SW_SHOWNORMAL = 1
Private Sub Form_Load()
'Send an E-Mail to the KPD-Team
ShellExecute Me.hwnd, vbNullString, "mailto:", vbNullString, "C:\", SW_SHOWNORMAL
End Sub
"mailto:"可以换为"mailto:langshanglibie@/doc/8e16312675.html ,"
注意:这样也可以:
一:打开程序
ShellExecute Me.hwnd, vbNullString, "QQ.exe", vbNullString, "D:\Program Files\腾迅QQ\", SW_SHOWNORMAL '启动QQ
二:打开文档
ShellExecute Me.hwnd, vbNullString, "林语堂语录.txt", vbNullString, "E:\唯有读书高\百科知识\", SW_SHOWNORMAL
'打开文本文档
ShellExecute Me.hwnd, vbNullString, "新建Microsoft Word 文档.doc", vbNullString, "E:\视觉盛宴\花前月下\唯美\", SW_SHOWNORMAL
'打开word文档
三:打开图象
ShellExecute Me.hwnd, vbNullString, "云桥.jpg", vbNullString, "E:\视觉盛宴\花前月下\唯美\", SW_SHOWNORMAL
ShellExecute Me.hwnd, vbNullString, "weimei (0).gif", vbNullString, "E:\视觉盛宴\花前月下\唯美\", SW_SHOWNORMAL
四:播放音乐
ShellExecute Me.hwnd, vbNullString, "（蔡依林）看我七十二变.mp3", vbNullString, "E:\天籁之音\", SW_SHOWNORMAL '因为在我的电脑中,（蔡依林）看我七十二变.mp3的关联程序的酷狗,故此文件是用酷狗打开的
五:视频也可以;
其它:ShellExecute Me.hwnd, vbNullString, "VB函数大全.chm", vbNullString, "F:\VB语言\", SW_SHOWNORMAL
-50:API函数之注册表函数
㈠:Re
gCreateKey函数
RegCreateKey
VB声明
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
说明
在指定的项下创建一个新项。

如指定的项已经存在，那么函数会打开现有的项
返回值
Long，零（ERROR_SUCCESS）表示成功。

其他任何值都代表一个错误代码
参数表
参数类型及说明
hKey Long，要打开项的句柄，或者一个标准项名
lpSubKey String，欲创建的新子项。

可同时创建多个项，只需用反斜杠将它们分隔开即可。

例如level1\level2\newkey
phkResult Long，指定一个变量，用于装载新子项的句柄
例如:
Dim hkey As Long
RegCreateKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", hkey 此时,变量hkey就拥有了
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentV ersion\Run的句柄
㈡:RegQueryValueEx函数
VB声明
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
说明
获取一个项的设置值
返回值
Long，零（ERROR_SUCCESS）表示成功。

其他任何值都代表一个错误代码
参数表
参数类型及说明
hKey Long，一个已打开项的句柄，或者指定一个标准项名
lpValueName String，要获取值的名字
lpReserved Long，未用，设为零
lpType Long，用于装载取回数据类型的一个变量
lpData Any，用于装载指定值的一个缓冲区
lpcbData Long，用于装载lpData缓冲区长度的一个变量。

一旦返回，它会设为实际装载到缓冲区的字节数
例如:
Private Declare Function RegCloseKey Lib "advapi32.dll"
(ByVal hkey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Const HKEY_LOCAL_MACHINE = &H80000002
Private Sub Command1_Click()
Dim hkey As Long, x As String, y As Long
RegCreateKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", hkey
RegQueryValueEx hkey, "KuGou", 0, 0, ByVal 0, y '次句的作用是取得y的值
x = String(y, Chr$(0))
RegQueryValueEx hkey, "KuGou", 0, 0, ByVal x, y
Print Left$(x, Len(x) - 1) '始终有一个空格
RegCloseKey hkey '关闭句柄
End Sub
㈢:RegCloseKey函数
VB声明
Declare Function RegCloseKey Lib "advapi32.dll" Alias "RegCloseKey" (ByVal hKey As Long) As Long
说明
关闭系统注册表中的一个项（或键）
返回值
Long，零（ERROR
_SUCCESS）表示成功。

其他任何值都代表一个错误代码
参数表
参数类型及说明
hKey Long，要关闭的项
例如:
Dim hkey As Long
RegCreateKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", hkey
regclosekey hkey
㈣:RegSetValueEx函数
VB声明
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
说明
设置指定项的值
返回值
Long，零（ERROR_SUCCESS）表示成功。

其他任何值都代表一个错误代码
参数表
参数类型及说明
hKey Long，一个已打开项的句柄，或指定一个标准项名
lpValueName String，要设置值的名字
Reserved Long，未用，设为零
dwType Long，要设置的数量类型
lpData Any，包含数据的缓冲区中的第一个字节
cbData Long，lpData缓冲区的长度
例如:
Dim Ret As Long
RegCreateKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", Ret
RegSetValueEx hKey, "时间助手", 0, REG_SZ, ByVal Exe, Len(Exe)
如果是二进制情况
RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(strData), 4
㈤:RegDeleteKey函数,必须是最后一个项,否则删除不掉
RegDeleteKey
VB声明
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
说明
删除现有项下方一个指定的子项
返回值
Long，零（ERROR_SUCCESS）表示成功。

其他任何值都代表一个错误代码
参数表
参数类型及说明
hKey Long，一个已打开项的句柄，或者标准项名之一
lpSubKey String，要删除项的名字。

这个项的所有子项也会删除例如:
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Sub Command1_Click()
Dim Ret As Long
RegCreateKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", Ret
RegDeleteKey Ret, "新项 #1"
End Sub
㈥:RegDeleteValue函数
VB声明
Declare Function RegDeleteValue Lib "advapi32.dll" Alias
"RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
说明
删除指定项下方的一个值
返回值
Long，零（ERROR_SUCCESS）表示成功。

其他任何值都代表一个错误代码
参数表
参数类型及说明
hKey Long，一个已打开项的句柄，或标准项名之一
lpValueName String，要删除的值名。

可设为vbNullString或一个空串，表示删除那个项的默认值
例如:
Private Declare Function R
egCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Sub Command1_Click()
Dim Ret As Long
RegCreateKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\新项 #1", Ret RegDeleteValue Ret, "新值 #1"
End Sub
-49:vb中声音函数
(一):sndPlaysound函数
Option Explicit
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10
Private Sub Form_Load()
Dim sFlags As Long
sFlags = SND_ASYNC Or SND_NODEFAULT
sndPlaySound "SystemStart", sFlags
End Sub
(二):playsound函数
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10
Private Sub Form_Load()
Dim sFlags As Long
sFlags = SND_ASYNC Or SND_NODEFAULT
sndPlaySound "SystemStart",0, sFlags
End Sub
注意:要想循环播放声音,用SND_ASYNC Or SND_LOOP参数声音文件还可以是这些:
SystemStart
SystemExit
SystemDefault
SystemQuestion
SystemAsterisk
SystemExclamation
SystemHand '跟错误声音差不多
-48:修改注册表,实现自启动
(一):使用批处理命令
导入注册表,实现开机自动运行
Set w = CreateObject("wscript.shell")
w.regwrite
"HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
取消自动运行
Set w = CreateObject("wscript.shell")
w.regdelete
"HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName
(二):使用API函数
'添加,删除自启动项目的API函数声明
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004 Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const REG_NONE = 0
Public Const REG_SZ = 1
Public Const REG_EXPAND_SZ = 2
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_MULTI_SZ = 7
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll"
Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
' 定义hKey为一个已打开项的句柄或指定一个标准项名(即5个主键名)、SubKey为注册表RUN项目路径、Exe为程序名变量
Dim hKey As Long, SubKey As String, Exe As String
Private Sub Command1_Click()
If Right(App.Path, 1) = "\" Then
Exe = App.Path + App.EXEName + ".exe" ' 根目录情况
Else: Exe = App.Path + "\" + App.EXEName + ".exe" ' 非根目录情况
End If
SubKey = "Software\Microsoft\Windows\CurrentVersion\Run" ' 设置项目RegCreateKey HKEY_LOCAL_MACHINE, SubKey, hKey ' 取得句柄
RegSetValueEx hKey, "时间助手", 0, REG_SZ, ByVal Exe, LenB(StrConv(Exe, vbFromUnicode)) + 1 ' 写入键值,Exe就是键值, RegCloseKey hKey ' 需要关闭句柄
End Sub
Private Sub Command2_Click()
SubKey = "Software\Microsoft\Windows\CurrentVersion\Run" ' 设置项目RegCreateKey HKEY_LOCAL_MACHINE, SubKey, hKey ' 取得句柄
RegDeleteValue hKey, "时间助手"
End Sub
-47:修改计算机名称：
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long
Private Sub Command1_Click()
SetComputerName "i love you"
End Sub
-46:连续创建好几个文件夹
Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
Private Sub Form_Load()
'create the directory 'c:\test\dir\hello\something\apiguide\' SHCreateDirectoryEx Me.hwnd, "c:\test\dir\hello\something\apiguide\", ByVal 0&
End Sub
-45:安装程序询问是否现在重新启动计算机
Private Declare Function SetupPromptReboot Lib "setupapi.dll" (ByRef FileQueue As Long, ByVal Owner As Long, ByVal ScanOnly As Long) As Long
Private Sub Form_Load()
SetupPromptReboot ByVal 0&, Me.hwnd, 0
End Sub
-44:用来Text1跟踪List1变化
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long Const LB_FINDSTRING = &H18F
Private Sub Form_Load()
With List1
.AddItem "Computer"
.AddItem "Screen"
.AddItem "Modem"
.AddItem "Printer"
.AddItem "Scanner"
.AddItem "Sound Blaster"
.AddItem "Keyboard"
.AddItem "CD-Rom"
.AddItem "Mouse"
End With
End Sub
Private Sub Text1_Change()
'Retrieve the item's listindex
List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal CStr(T ext1.Text)) '跟踪List1变化
End Sub
-43:连续创建好几个文件夹
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Private Sub Form_Load()
'create the directory "c:\this\is\a\test\directory\", if it doesn't exist already
MakeSureDirectoryPathExists "c:\this\is\a\test\directory\"
End Sub
而Mkdir只能创建一个文件夹
-42:不懂的一个函数
Private Declare Function LockWorkStation Lib "user32.dll" () As Long
Private Sub Form_Load()
LockWorkStation
End Sub
-41:判断是否连接网络
Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Private Declare Function IsNetworkAlive Lib "SENSAPI.DLL" (ByRef lpdwFlags As Long) As Long
Private Sub Form_Load()
Dim Ret As Long
If IsNetworkAlive(Ret) = 0 Then
MsgBox "The local system is not connected to a network!"
Else
MsgBox "The local system is connected to a " + IIf(Ret = NETWORK_ALIVE_AOL, "AOL", IIf(Ret = NETWORK_ALIVE_LAN, "LAN", "WAN")) + " network!"
End If
End Sub
-40：得到windows安装路径
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Form_Load()
Dim sSave As String, Ret As Long
'Create a buffer
sSave = Space(255)
'Get the system directory。