VB集锦(API)

正常结束由Shell所调用的Window 程序

我们曾在使"Shell指令具Wait功能"的文章中
提过，使用TerminateProcess()来结束一个由Shell所调用的Process，但也说过，这可
能会有一些问题，如果说，所调用的是一般正常且单一的Window程序(如NotePad)，那
是有办法令之正常结束的，那便是使用PostMessage(hWnd, WM_CLOSE,0,0)，令该Window
结束。然而，Shell的传回值是Process ID而不是hWnd，所以要加一些动作来取得hWnd。
我们可以用 GetForegroundWindow来做(如果该Shell是指定vbNormalFocus)，另也可以使
用FindWindow来做，但是，如果有两个NotePad在时，会取到那一个，实在不知。另外使
EnumWindows来做，该Function用来巡行Top Level的Window，我们传入ProcessID当做
EnumWindows的第二个叁数，於是EnumWindowProcedure中的lParam便是该ProcessID，我
们另外用tid = GetWindowThreadProcessId(hwnd, pid)来取得hWnd所属的ProcessID
与我们传入的ProcessID(lParam)做比较，若相同，代表我们已找到所要的hWnd了。
EnumWindows的用法请叁考"尝试寻找电脑中执行的程序"

当然，这个程序的做法不是万能的，如果产生的Process又产生有好多个Window，我们结束
的，可能只是其中之一，那程序可能要改一下，变成只要在EnumWindow Procedure中找到
一个PID与Shell传回值的PID相同者，就使用PostMessage(hwnd, WM_CLOSE, 0,0)来结束
之，但这也不一定就全然可行，如果产生的不是一个有Window的程序，那使用WM_CLOSE
是没有用的，唯一能做的，就是使用TerminateProcess来强迫中断程序。

以下程序在.BAS

 
 
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Declare Function SetForegroundWindow Lib "user32" Alias "SetForegroundWindow" (ByVal hwnd As Long) As Long
Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
     ByVal dwProcessId As Long) As Long
Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long
Declare Function TerminateProcess Lib "kernel32" _
    (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
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

Public Const SYNCHRONIZE = &H100000
Public Const STILL_ALIVE = &H103
Public Const INFINITE = &HFFFF
Public Const WM_CLOSE = &H10
Public hWnd5 As Long
Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Boolean
    Dim S As String
    If GetParent(hwnd) = 0 Then
       Dim tid As Long, pid As Long
       tid = GetWindowThreadProcessId(hwnd, pid)
       If pid = lParam Then
	  hWnd5 = hwnd
	  EnumWindowsProc = False
       End If
    End If
    EnumWindowsProc = True ' 表示继续列举 hWnd
End Function

以下程序在Form

Option Explicit
 Private ExitCode As Long
 Private hProcess As Long
 Private isDone As Long
 Private Sub Command1_Click()
 Dim pid As Long
 pid = Shell("notepad.exe", vbNormalFocus)
 Call EnumWindows(AddressOf EnumWindowsProc, pid) '设定hWnd5的值
 hProcess = OpenProcess(SYNCHRONIZE , 0, pid)
 isDone = False
 Do
   Call GetExitCodeProcess(hProcess, ExitCode)
   DoEvents
 Loop While ExitCode = STILL_ALIVE Or isDone
 Call CloseHandle(hProcess)
 isDone = True
 Label1.Caption = "Over"
 End Sub

 Private Sub Command2_Click()
 Dim i As Long
 Call SetForegroundWindow(hWnd5)
 Call PostMessage(hWnd5, WM_CLOSE, 0, 0)
 End Sub

 Private Sub Form_Unload(Cancel As Integer)
 isDone = True
 End Sub

 如何Restart Shell(Explorer.exe)

其实这程式是找出Explorer所在的Window，而後用WM_QUIT令之结束，再用一个Loop等待Explorer 的结束，最後才用Sell指令执行Explorer.exe；

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, _ ByVal lParam As Long) As Long Const WM_QUIT = &H12 Private Sub Form_Load() Dim hwndShell As Long, i As Long hwndShell = FindWindow("Progman", vbNullString) i = PostMessage(hwndShell, WM_QUIT, 0, 0) If i = 0 Then Exit Sub Do While True '等待原先的Shell结束 hwndShell = FindWindow("Progman", vbNullString) If hwndShell = 0 Then Exit Do End If Loop Shell "Explorer.exe", vbNormalFocus '执行新的Shell End Sub

判断程式是独立执行还是在VB环境下执行

此时可呼叫 GetModuleFileName API 函数判断执行档名称是否为 VB5，如果是 VB5
， 则GetModuleFileName 最右边的 7 个字元将等於 "VB5.EXE"，

Private Declare Function GetModuleFileName Lib "kernel32" Alias _
        "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As _
        String, ByVal nSize As Long) As Long

Function IsRunUnderVB5() As Boolean
 Dim S As String, Length
 Length = 256
 S = String(Length, 0)
 Call GetModuleFileName(0, S, Length)
 S = Left(S, InStr(S, Chr(0)) - 1)
 IsRunUnderVB5 = UCase(Right(S, 7)) = "VB5.EXE"
End Function

爆炸式显示表单

这是一个显示表单的特殊效果(由小变大)


 
 
Option Explicit
 Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, _
         ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
 Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
         ByVal hObject As Long) As Long
 Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
 Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long

Private hbrush As Long, hdc5 As Long

Private Sub Form_Load()
Dim dx  As Long, dy As Long
Dim rx1 As Long, rx2 As Long, ry1 As Long, ry2 As Long
Dim i As Long, j As Long, bcolor As Long
Dim DispCnt As Long

DispCnt = 60 '一共Display多少次榘形後才显示Form
hdc5 = GetDC(0)
bcolor = GetBkColor(Me.hdc) '取得form的背景色
'注：之所以不使用me.BackColor的原因是：这个属性不一定使用调色盘，
'    如果使用系统配色，那结果会不对
hbrush = CreateSolidBrush(bcolor) '设定笔刷颜色
Call SelectObject(hdc5, hbrush)
dx = Me.Width / (DispCnt * 2)
dy = Me.Height / (DispCnt * 2)
j = 1
For i = DispCnt To 1 Step -1
    rx1 = (Me.Left + dx * (i - 1)) / Screen.TwipsPerPixelX
    ry1 = (Me.Top + dy * (i - 1)) / Screen.TwipsPerPixelY
    rx2 = rx1 + dx * 2 * j / Screen.TwipsPerPixelX
    ry2 = rx1 + dy * 2 * j / Screen.TwipsPerPixelY
    j = j + 1
    Call Rectangle(hdc5, rx1, ry1, rx2, ry2)
    Sleep (1)
Next i
Call ReleaseDC(0, hdc5)
Call DeleteObject(hbrush)
End Sub

如何让Window不接受键盘输入及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

按下HotKey以叫起视窗

如何做到在任何一个程式之下，按下某个HotKey组合键，便将我们的视窗Activate起来， 这便得使用 WM_SETHOTKEY 来达成 WM_SETHOTKEY所需的叁数如下： wParam = (WPARAM) MAKEWORD(vkey, modifiers) lParam = 0 vkey 指的是virtual-key code，它是在低位元组，modifier是以下四种键的组合，它是 在高位元组。 HOTKEYF_ALT ALT key HOTKEYF_CONTROL CTRL key HOTKEYF_EXT Extended key HOTKEYF_SHIFT SHIFT SendMessage()的传回值有以下的意义： -1 hotkey 设定不对 0 hWnd的指定有误 1 成功，而且没有其他window的HotKey与之相同 2 成功，但有其他window的HotKey与之相同

Option Explicit 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 WM_SETHOTKEY = &H32 Const HOTKEYF_SHIFT = &H1 Const HOTKEYF_CONTROL = &H2 Const HOTKEYF_ALT = &H4 Const HOTKEYF_EXT = &H8 Private Type tInteger aint As Integer End Type Private Type t2Byte lByte As Byte hByte As Byte End Type Private ii As tInteger Private bb As t2Byte Private Sub Command1_Click() Dim wParam As Long, I As Long '设定ctl-shift-T 为该window的hotkey bb.hByte = HOTKEYF_CONTROL Or HOTKEYF_SHIFT bb.lByte = vbKeyT LSet ii = bb wParam = CLng(ii.aint) I = SendMessage(Me.hwnd, WM_SETHOTKEY, wParam, 0) If I = 1 Then Debug.Print "Ctl-Shift-T 为hotkey" Else If I = 2 Then Debug.Print "有其他Window也用Ctl-Shift-T当Hotkey" Else Debug.Print "指定失败" End If End If End Sub

VB中LostFocus、GotFocus事件的改进

---- VB中有一个LostFocus事件和一个GotFocus事件，看名字似乎是当当前窗口失去焦点或得到焦点时触发的事件。但在实际应用时却发现当这个窗口和Windows中其他窗口进行切换时并没有触发这两个事件。现在解析一下这两个事件。

---- Form_LostFocus、Form_GotFocus是指的是一个MDI主父窗体调用了多个子窗体，当这些子窗体之间切换时，就触发这两个事件；当一个窗体中的多个文本框，鼠标点击另一个文本框时，也会触发这两个此事件，文本框在 Windows内部实际上也是一个窗口。

---- Windows内部是通过消息来触发事件的，这两个事件在Windows内部对应的消息是WM_NCACTIVATE，当该消息的wParam为0时表示是失去焦点，为非0时表示得到焦点。在模块中：

Public Declare Function SetWindowLong Lib
"user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long,
ByVal dwNewLong As Long) As Long

Public Declare Function DefWindowProc Lib
"user32" Alias "DefWindowProcA"_
(ByVal hwnd As Long, ByVal wMsg As Long,
ByVal wParam As Integer, ByVal_
lParam As Long) As Long

Public 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 WM_NCACTIVATE = &H86
Public Const GWL_WNDPROC = (-4)
Public OldWndProc&

Public Function Hook&(ByVal hWnd1&)
    OldWndProc = SetWindowLong(hWnd1,
GWL_WNDPROC, AddressOf NewWndProc)
Hook = OldWndProc
End Function

Public Sub UnHook(ByVal hWnd1&)
    SetWindowLong hWnd1, GWL_WNDPROC, OldWndProc
End Sub

Public Function NewWndProc&(ByVal hWnd1&, ByVal uMsg&,
ByVal wParam&, ByVal lParam&)
    If uMsg = WM_NCACTIVATE Then
    If wParam = 0 Then ’失去焦点
    Form1.Caption = "失去焦点"
'在这里加入在失去焦点时想要执行的代码
    Else
Form1.Caption = "得到焦点"   
’在这里加入在得到焦点时想要执行的代码
    End If
    End If
    NewWndProc = CallWindowProc(OldWndProc,
hWnd1, uMsg, wParam, lParam)
End Function

窗口中代码如下：

Private Sub Form_Load()
    Hook Form1.hwnd
End Sub

Private Sub Form_QueryUnload(Cancel As Integer,
UnloadMode As Integer)
    UnHook Form1.hwnd
End Sub

---- 注意：在编写“失去焦点”和“得到焦点”的代码时，不要使用VB本身自带的函数，如： MsgBox()和Print()等，因为这里不支持，要用MessageBox()、TextOut()等API函数来代替,否则VB会出现“非法保护性错误”而把VB连带程序一起关掉。
---- 本程序在VB6.0企业版中调试通过。

								

在 VB 里面， 原本改变预设打印机的方法是：(假设安装有两种打印机(驱动程式))	

             Set Printer = Printers(0) ' 将预设打印机设定成第一种打印机
             Set Printer = Printers(1) ' 将预设打印机设定成第二种打印机

但实际上以上叙述有时候不会成功(原因不详)， 为了能够成功地改变预设打印机，
以下是呼叫Windows API 的方法：( 此一解决方案适用於 Windows 95)

1. API 的宣告：

Const HWND_BROADCAST = &HFFFF&
Const WM_WININICHANGE = &H1A

Private Declare Function GetProfileString Lib "kernel32" Alias  _
        "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As _
        String, ByVal lpDefault As String, ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long

Private Declare Function WriteProfileString Lib "kernel32" Alias _
        "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName _
        As String, ByVal lpszString 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

2. 程式范例：

PrinterName = "您想设定的打印机名称"
Dim S As String, length As Long, hKey As Long

S = String(80, Chr(0))
length = GetProfileString("devices", PrinterName, "", S, Len(S))
S = Left(S, length)
Call WriteProfileString("windows", "device", PrinterName & "," & S)
Call SendMessage(HWND_BROADCAST, WM_WININICHANGE, &H7FFF&, ByVal "windows")


至於改变 NT 预设打印机的方法， 则是改变登录资料库(Registry)打印机的设定，
在登录资料库中纪录
              预设打印机的 Value 是:

  HKEY_CURRENT_USER
  /Software/Microsoft/WindowsNT/CurrentVersion/Windows subkey 的
  Device value