2007-05-18 14:31:28
Kenny
自編的VB6.0調用WinAPI的模組
透過我的多次實踐,在編寫了許多軟體的基礎上,我自編和整合了許多較實用的函數。
注意,以下代碼前半部分為WinAPI函數的聲明,後半部分為自編函數和過程。
Option Explicit On
'-----------------------------------------------------------------------------------
' FileName: modCommon.bas
' Function: 通用的變量、常量聲明,自編函數、過程以及API函數聲明
'-----------------------------------------------------------------------------------
'----------------------- 常量聲明 -----------------------
Public Const User_Pi = 3.1415926 'PI
Public Const User_Golden = 0.618 '黃金分割比例
'----------------------- WindowAPI 函數聲明 -----------------------
'設定一個窗口的位置和狀態
Public 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
'{
'hwnd 欲定位的窗口
'hWndInsertAfter 窗口句柄。在窗口清單中,窗口hwnd會置於這個窗口句柄的後面
Public Const HWND_BOTTOM = 1 '將窗口置於窗口清單底部
Public Const HWND_TOP = 0 '將窗口置於Z序列的頂部;Z序列代表在分級結構中,窗口針對一個給定級別的窗口顯示的順序
Public Const HWND_TOPMOST = -1 '將窗口置於清單頂部,並位於任何最頂部窗口的前面
Public Const HWND_NOTOPMOST = -2 '將窗口置於清單頂部,並位於任何最頂部窗口的後面
'x,y 窗口新的x,y坐標
'cx,cy 指定新的窗口寬度和高度
'wFlags 包含了旗標的一個整數,是下列之一,返回值Long,非零表示成功,零表示失敗
Public Const SWP_DRAWFRAME = &H20 '圍繞窗口畫一個框
Public Const SWP_HIDEWINDOW = &H80 '隱藏窗口
Public Const SWP_NOACTIVATE = &H10 '不激活窗口
Public Const SWP_NOMOVE = &H2 '保持目前位置(x和y設定將被忽略)
Public Const SWP_NOREDRAW = &H8 '窗口不自動重畫
Public Const SWP_NOSIZE = &H1 '保持目前大小(cx和cy會被忽略)
Public Const SWP_NOZORDER = &H4 '保持窗口在清單的目前位置(hWndInsertAfter將被忽略)
Public Const SWP_SHOWWINDOW = &H40 '顯示窗口
Public Const SWP_FRAMECHANGED = &H20 '強迫一條WM_NCCALCSIZE消息進入窗口,即使窗口的大小沒有改變
'}
'從指定窗口的結構中取得資訊
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'{
'hwnd 欲為其穫取資訊的窗口的句柄
'nIndex 欲取回的資訊,可以是下述任何一個常數:
Public Const GWL_EXSTYLE = (-20) '擴展窗口樣式
Public Const GWL_STYLE = (-16) '窗口樣式
Public Const GWL_WNDPROC = (-4) '該窗口的窗口函數的地址
Public Const GWL_HINSTANCE = (-6) '擁有窗口的實例的句柄
Public Const GWL_HWNDPARENT = (-8) '該窗口之父的句柄?不要用SetWindowWord來改變這個值
Public Const GWL_ID = (-12) '對話方塊中一個子窗口的標識符
Public Const GWL_USERDATA = (-21) '含義由應用程式規定
Public Const DWL_DLGPROC = 4 '這個窗口的對話方塊函數地址
Public Const DWL_MSGRESULT = 0 '在對話方塊函數中處理的一條消息返回的值
Public Const DWL_USER = 8 '含義由應用程式規定
Public Const WS_MINIMIZEBOX = &H20000 '最小化按鈕
Public Const WS_MAXIMIZEBOX = &H10000 '最大化按鈕
'}
'在窗口結構中為指定的窗口設定資訊
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'{
'返回值Long,指定數據的前一個值
'hwnd 欲為其取得資訊的窗口的句柄
'nIndex 請參考GetWindowLong函數的nIndex參數的說明
'dwNewLong 由nIndex指定的窗口資訊的新值
'}
'設定窗體的層次屬性
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'{
'hwnd 窗口手柄。當使用CreateWindowEx函數創建窗口時,窗口由WS_EX_LAYERED指定的值創建;
' 或者窗口已經創建後,由SetWindowLong根據WS_EX_LAYERED指定的值改變。
Public Const WS_EX_LAYERED = &H80000
'crKey 指定顏色值。指向一個COLOR值,該值指定一個透明顏色值,當創建窗口時,窗口將使用該值。
'bAlpha 混合函數值該值。用於描述窗口的不透明度。當bAlpha 值為時,窗口完全透明,
' 當bAlpha值為時,窗口完全不透明。
'dwFlags 動作。這個參數可以取一個或多個值。用它我們可以創建一個不規則的窗體。
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
'}
'系統欄圖示顯示
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, ByVal lpData As NOTIFYICONDATA) As Long
'{
'dwMessage
Public Const NIM_ADD = &H0 '添加圖示到系統欄提示區
Public Const NIM_DELETE = &H2 '刪除托盤中的圖示
Public Const NIM_MODIFY = &H1 '修改系統狀態列中的圖示
'lpData
Public Const MAX_TOOLTIP As Integer = 64
Public Type NOTIFYICONDATA
cbSize As Long '改變結構所佔地位元組數
hwnd As Long '接受托盤圖示資訊的窗體
uID As Long '為圖示設定的ID
uFlags As Long '設定下面三項是否有效
uCallbackMessage As Long '消息的編號
hIcon As Long '托盤圖示的句柄
szTip As String * MAX_TOOLTIP '滑鼠指到托盤圖示時顯示的提示字元串
End Type
Public nfIconData As NOTIFYICONDATA '定義一個變量nfIconData來記錄設定托盤圖示的數據
Public Const NIF_ICON = &H2 '圖示
Public Const NIF_MESSAGE = &H1 '資訊
Public Const NIF_TIP = &H4 '提示
'滑鼠事件
Public Const WM_MOUSEMOVE = &H200 '在圖示上移動滑鼠
Public Const WM_LBUTTONDOWN = &H201 '滑鼠左鍵按下
Public Const WM_LBUTTONUP = &H202 '滑鼠左鍵釋放
Public Const WM_LBUTTONDBLCLK = &H203 '連續按兩下滑鼠左鍵
Public Const WM_RBUTTONDOWN = &H204 '滑鼠右鍵按下
Public Const WM_RBUTTONUP = &H205 '滑鼠右鍵釋放
Public Const WM_RBUTTONDBLCLK = &H206 '連續按兩下滑鼠右鍵
Public Const WM_SETHOTKEY = &H32 '響應您定義的熱鍵
'}
'穫取*.Ini文件資訊
Public 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
'{
'參數
'lpApplicationName 欲在其中查找條目的小節名稱。這個字串不區分大小寫。如設為vbNullString,就在lpReturnedString緩衝區內裝載這個ini文件所有小節的清單
'lpKeyName 欲穫取的項名或條目名。這個字串不區分大小寫。如設為vbNullString,就在lpReturnedString緩衝區內裝載指定小節所有項的清單
'lpDefault 指定的條目沒有找到時返回的默認值。可設為空("")
'lpReturnedString 指定一個字串緩衝區,長度至少為nSize
'nSize 指定裝載到lpReturnedString緩衝區的最大字元數量
'lpFileName 初始化文件的名字。如沒有指定一個完整路徑名,windows就在Windows目錄中查找文件
'}
'寫入資訊到*.Ini文件
Public 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
'{
'參數
'lpApplicationName 要在其中寫入新字串的小節名稱。這個字串不區分大小寫
'lpKeyName 要設定的項名或條目名。這個字串不區分大小寫。用vbNullString可刪除這個小節的所有設定項
'lpString 指定為這個項寫入的字串值。用vbNullString表示刪除這個項現有的字串
'lpFileName 初始化文件的名字。如果沒有指定完整路徑名,則windows會在windows目錄查找文件。如果文件沒有找到,則函數會創建它
'}
'判斷系統中存在哪些邏輯驅動器字母
Public Declare Function GetLogicalDrives Lib "kernel32" () As Long
'{
'返回值
'Long,這個結構中的二進制位標志著存在哪些驅動器。其中,位設為表示驅動器A:存在於系統中
'}
'判斷一個磁碟驅動器的類型
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'{
'nDrive 包含了驅動器根目錄路徑的一個字串
'返回值
'如驅動器不能識別,則返回零。如指定的目錄不存在,則返回.
'如執行成功,則用下述任何一個常數指定驅動器類型:
Public Const DRIVE_CDROM = 5 'CD-ROM驅動器
Public Const DRIVE_FIXED = 3 '固定驅動器
Public Const DRIVE_RAMDISK = 6 '記憶體驅動器
Public Const DRIVE_REMOTE = 4 '網路驅動器
Public Const DRIVE_REMOVABLE = 2 '可移動驅動器
'}
'穫取與一個磁碟卷有關的資訊
Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, ByVal lpVolumeSerialNumber As Long, ByVal lpMaximumComponentLength As Long, ByVal lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
'{
'參數表
'lpRootPathName 欲穫取資訊的那個卷的根路徑
'lpVolumeNameBuffer 用於裝載卷名(卷標)的一個字串
'nVolumeNameSize lpVolumeNameBuffer字串的長度
'lpVolumeSerialNumber 用於裝載磁碟卷序列號的變量
'lpMaximumComponentLength 指定一個變量,用於裝載檔案名稱每一部分的長度。例如,在“c:\component1\component2.ext”的情況下,它就代表component1或component2名稱的長度
'lpFileSystemFlags 用於裝載一個或多個二進制位標志的變量。對這些標志位的解釋如下:
'
'FS_CASE_IS_PRESERVED 檔案名稱的大小寫記錄於文件系統
'FS_CASE_SENSITIVE 檔案名稱要區分大小寫
'FS_UNICODE_STORED_ON_DISK 檔案名稱保存為Unicode格式
'FS_PERSISTANT_ACLS 文件系統支援文件的訪問控制清單(ACL)安全機制
'FS_FILE_COMPRESSION 文件系統支援逐文件的進行文件壓縮
'FS_VOL_IS_COMPRESSED 整個磁碟卷都是壓縮的
'
'lpFileSystemNameBuffer 指定一個緩衝區,用於裝載文件系統的名稱(如FAT,NTFS以及其他)
'nFileSystemNameSize lpFileSystemNameBuffer字串的長度
'}
'尋找窗口清單中第一個符合指定條件的頂級窗口
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'{
'返回值為找到窗口的句柄。如未找到相符窗口,則返回零。
'參數表
'lpClassName 指向包含了窗口類名的空中止(C語言)字串的指針;或設為零,表示接收任何類
'lpWindowName 指向包含了窗口文本(或標簽)的空中止(C語言)字串的指針;或設為零,表示接收任何窗口標題
'}
'將指針限制到指定區域
Public Declare Function ClipCursor& Lib "user32" (ByVal lpRect As RECT)
'{
'參數表
'lpRect RECT 指定一個矩形,用像素螢幕坐標系統表示,滑鼠指針必須在這個區域內運動。
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
'}
'穫得整個窗口的範圍矩形,窗口的邊框、標題列、卷軸及菜單等都在這個矩形內
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As RECT) As Long
'{
'參數表
'hwnd 想穫得範圍矩形的那個窗口的句柄
'lpRect RECT 螢幕坐標中隨同窗口裝載的矩形
'}
'取得一個矩形,用於描述目前為滑鼠指針規定的剪下來區域;該區域是由SetClipCursor函數定義的
Public Declare Function GetClipCursor Lib "user32" (ByVal lprc As RECT) As Long
'{
'參數表
'lprc RECT 在螢幕坐標系統中隨同目前剪下來矩形載入的一個矩形。
' 倘若沒有活動的剪下來,這個矩形會反映出整個顯示螢幕的大小
'}
'設定指針的位置
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'{
'參數表
'x,y 滑鼠指針在螢幕像素坐標系統中的X,Y位置
'}
'穫得代表整個螢幕的一個窗口(桌面窗口)句柄
Public Declare Function GetDesktopWindow Lib "user32" () As Long
'{
'返回值Long,桌面窗口的句柄
'}
'控制滑鼠的顯示
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
'{
'參數
'bShow TRUE(非零)顯示指針,FALSE隱藏
'}
'設定某一機碼的健值
Public 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
'{
'參數
'hKey 一個已打開項的句柄,或指定一個標準項名
'lpSubKey 欲對它的值進行設定的一個子項的名字。如指定vbNullString,表示設定hKey的默認值
' 如指定的子項不存在,則會創建它
'dwType 必須是REG_SZ
'lpData 新值
'cbData 指定lpData的長度,不包括空中止字元
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
'}
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As Any, ByVal cbData As Long) As Long
'{
'參數
'hKey Long,一個已打開項的句柄,或指定一個標準項名
'lpValueName String,要設定值的名字
'Reserved Long,未用,設為零
'dwType Long,要設定的數量類型
'lpData Any,包含數據的緩衝區中的第一個位元組
'cbData Long,lpData緩衝區的長度
'}
'創建一個機碼
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal phkResult As Long) As Long
'{
'參數
'hKey 要打開項的句柄,或者一個標準項名
'lpSubKey 欲創建的新子項。可同時創建多個項,只需用反斜杠將它們分隔開即可。例如level1\level2\newkey
'phkResult 指定一個變量,用於裝載新子項的句柄
'}
'關閉對註冊表機碼的操作
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'{
'參數
'hKey 要關閉的項
'}
'刪除指定項下方的一個值
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
'{
'參數
'hKey Long,一個已打開項的句柄,或標準項名之一
'lpValueName String,要刪除的值名。可設為vbNullString或一個空串,表示刪除那個項的默認值
'}
'打開一個現有的註冊表項
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal phkResult As Long) As Long
'{
'參數
'hKey Long,一個已打開項的句柄,或指定一個標準項名
'lpSubKey String,要打開的項名
'phkResult Long,指定一個變量,用於裝載(保存)打開註冊表項的一個句柄
'}
'----------------------- 自定義函數 -----------------------
'穫取*.Ini文件資訊
Function GetFromIni(ByVal sSection As String, ByVal sKey As String, ByVal sDefault As String, ByVal sFileName As String) As String
Dim rs As String
rs = String(255, " ")
GetPrivateProfileString(sSection, sKey, sDefault, rs, Len(rs) - 1, sFileName)
rs = left(rs, InStr(rs, Chr(0)) - 1)
GetFromIni = rs
End Function
'寫入資訊到*.Ini文件
Function WriteToIni(ByVal sSection As String, ByVal sKey As String, ByVal sValue As String, ByVal sFileName As String)
WritePrivateProfileString(sSection, sKey, sValue, sFileName)
End Function
'加密字元串
Function Encrypt(ByVal PlainStr As String, ByVal Key As String) As String
Dim n As Integer, every As Integer, word As Integer, pwd As String
For n = 1 To Len(PlainStr)
every = Asc(Mid(PlainStr, n, 1)) + n
word = every + Key
pwd = pwd & word
Next n
Encrypt = pwd
End Function
'解密字元串
Function Decrypt(ByVal PlainStr As String, ByVal Key As String) As String
Dim n As Integer, every As Integer, word As Integer, pwd As String
For n = 1 To Len(PlainStr)
every = Asc(Mid(PlainStr, n, 1))
word = (every + Key) - n
pwd = pwd & word
Next n
Decrypt = pwd
End Function
'根據字元串本身,形成密鑰
Function SecretKey(ByVal souKey As String) As Integer
Dim n As Integer, every As Integer, word As Integer
n = 1
word = Asc(Mid(souKey, n, 1))
For n = 2 To Len(souKey)
every = Asc(Mid(souKey, n, 1))
word = word Xor every
Next n
SecretKey = word
End Function
'將邏輯驅動器的二進制數據轉換為盤符數據
Function BinToWord(ByVal souBin As String) As String
Dim num As Integer, n As Integer, rs As String, every As String
n = 1
For num = Len(souBin) To 1 Step -1
every = Mid(souBin, num, 1)
If every = 1 Then
rs = rs & Chr(65 - 1 + n)
End If
n = n + 1
Next num
BinToWord = rs
End Function
'將十進制轉換為二進制
Function DecToBin(ByVal souDec As Long) As String
Dim numMod As Integer, numLeft As Long, rs As String
Do
numMod = souDec Mod 2
numLeft = souDec \ 2
rs = numMod & rs
souDec = numLeft
Loop Until (souDec = 0)
DecToBin = rs
End Function
'穫得邏輯驅動器的序列號
Function GetDriverSn(ByVal strDriver As String) As String
Dim strLabel As String
Dim lSerialnum As Long
Dim strType As String
GetVolumeInformation(strDriver, strLabel, Len(strLabel), lSerialnum, 0, 0, strType, Len(strType))
GetDriverSn = Hex(lSerialnum)
End Function
'判斷指定類或窗體是否存在
Function IsProcessOrForm(ByVal sClass As String, ByVal sCaption As String) As Boolean
Dim winHwnd As Long
winHwnd = FindWindow(sClass, sCaption)
If winHwnd = 0 Then
IsProcessOrForm = False
Else
IsProcessOrForm = True
End If
End Function
'查找指定窗體
Function ScanWindow(ByVal sCaption As String) As Boolean
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, sCaption)
If winHwnd = 0 Then
ScanWindow = False
Else
ScanWindow = True
End If
End Function
'----------------------- 自定義過程 -----------------------
'將窗體置於螢幕中央
Public Sub FormCenter(ByVal souForm As Form)
souForm.left = (Screen.Width - souForm.Width) / 2
souForm.top = (Screen.Height - souForm.Height) * (1 - User_Golden)
End Sub
'將窗體最大化整個螢幕
Public Sub FormMax(ByVal souForm As Form)
souForm.top = 0
souForm.left = 0
souForm.Height = Screen.Height
souForm.Width = Screen.Width
End Sub
'將窗體置於頂端
Public Sub FormOnTop(ByVal souForm As Form)
SetWindowPos(souForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub
'窗體的半透明化處理
Public Sub Translucence(ByVal souForm As Form, ByVal Degree As Integer)
Dim rtn As Long
rtn = GetWindowLong(souForm.hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong(souForm.hwnd, GWL_EXSTYLE, rtn)
SetLayeredWindowAttributes(souForm.hwnd, 0, Degree, LWA_ALPHA)
End Sub
'在系統欄裏添加圖示
Public Sub TrayAddIcon(ByVal souForm As Form, ByVal ToolText As String)
With nfIconData
.hwnd = souForm.hwnd
.uID = souForm.Icon
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = souForm.Icon.Handle
.szTip = ToolText & vbNullChar
.cbSize = Len(nfIconData)
End With
Call Shell_NotifyIcon(NIM_ADD, nfIconData)
End Sub
'把系統欄中的圖示刪除
Public Sub TrayDelIcon()
Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
End Sub
'將滑鼠限制在ctl區域內
Public Sub ClipToControl(ByVal ctl As Object)
Dim hwnd As Long
Dim t As RECT
hwnd = ctl.hwnd
GetWindowRect(hwnd, t)
SetCursorPos(t.left + (t.right - t.left) / 2, t.top + (t.bottom - t.top) / 2)
ClipCursor(t)
End Sub
'解除對滑鼠移動的限制
Public Sub ClipToDesktop()
Dim t As RECT
GetWindowRect(GetDesktopWindow(), t)
ClipCursor(t)
End Sub
'隱藏滑鼠
Public Sub HideMouse()
ShowCursor(0)
End Sub
'顯示滑鼠
Public Sub ShowMouse()
ShowCursor(1)
End Sub
'將程式加入自動運行
Public Sub RegAddAutorun(ByVal regName As String, ByVal regData As String)
Dim regHand As Long
Dim appFileName As String
appFileName = App.Path & "\lockmanagement.exe"
RegOpenKey(HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentVersion\run", regHand)
RegSetValueEx regHand, regName, 0, REG_SZ, ByVal regData, Len(regData)
RegCloseKey(regHand)
End Sub
'解除程式的自動運行
Public Sub RegRemoveAutorun(ByVal regName As String)
Dim regHand As Long
RegOpenKey(HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentVersion\run", regHand)
RegDeleteValue(regHand, regName)
RegCloseKey(regHand)
End Sub
注意,以下代碼前半部分為WinAPI函數的聲明,後半部分為自編函數和過程。
Option Explicit On
'-----------------------------------------------------------------------------------
' FileName: modCommon.bas
' Function: 通用的變量、常量聲明,自編函數、過程以及API函數聲明
'-----------------------------------------------------------------------------------
'----------------------- 常量聲明 -----------------------
Public Const User_Pi = 3.1415926 'PI
Public Const User_Golden = 0.618 '黃金分割比例
'----------------------- WindowAPI 函數聲明 -----------------------
'設定一個窗口的位置和狀態
Public 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
'{
'hwnd 欲定位的窗口
'hWndInsertAfter 窗口句柄。在窗口清單中,窗口hwnd會置於這個窗口句柄的後面
Public Const HWND_BOTTOM = 1 '將窗口置於窗口清單底部
Public Const HWND_TOP = 0 '將窗口置於Z序列的頂部;Z序列代表在分級結構中,窗口針對一個給定級別的窗口顯示的順序
Public Const HWND_TOPMOST = -1 '將窗口置於清單頂部,並位於任何最頂部窗口的前面
Public Const HWND_NOTOPMOST = -2 '將窗口置於清單頂部,並位於任何最頂部窗口的後面
'x,y 窗口新的x,y坐標
'cx,cy 指定新的窗口寬度和高度
'wFlags 包含了旗標的一個整數,是下列之一,返回值Long,非零表示成功,零表示失敗
Public Const SWP_DRAWFRAME = &H20 '圍繞窗口畫一個框
Public Const SWP_HIDEWINDOW = &H80 '隱藏窗口
Public Const SWP_NOACTIVATE = &H10 '不激活窗口
Public Const SWP_NOMOVE = &H2 '保持目前位置(x和y設定將被忽略)
Public Const SWP_NOREDRAW = &H8 '窗口不自動重畫
Public Const SWP_NOSIZE = &H1 '保持目前大小(cx和cy會被忽略)
Public Const SWP_NOZORDER = &H4 '保持窗口在清單的目前位置(hWndInsertAfter將被忽略)
Public Const SWP_SHOWWINDOW = &H40 '顯示窗口
Public Const SWP_FRAMECHANGED = &H20 '強迫一條WM_NCCALCSIZE消息進入窗口,即使窗口的大小沒有改變
'}
'從指定窗口的結構中取得資訊
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'{
'hwnd 欲為其穫取資訊的窗口的句柄
'nIndex 欲取回的資訊,可以是下述任何一個常數:
Public Const GWL_EXSTYLE = (-20) '擴展窗口樣式
Public Const GWL_STYLE = (-16) '窗口樣式
Public Const GWL_WNDPROC = (-4) '該窗口的窗口函數的地址
Public Const GWL_HINSTANCE = (-6) '擁有窗口的實例的句柄
Public Const GWL_HWNDPARENT = (-8) '該窗口之父的句柄?不要用SetWindowWord來改變這個值
Public Const GWL_ID = (-12) '對話方塊中一個子窗口的標識符
Public Const GWL_USERDATA = (-21) '含義由應用程式規定
Public Const DWL_DLGPROC = 4 '這個窗口的對話方塊函數地址
Public Const DWL_MSGRESULT = 0 '在對話方塊函數中處理的一條消息返回的值
Public Const DWL_USER = 8 '含義由應用程式規定
Public Const WS_MINIMIZEBOX = &H20000 '最小化按鈕
Public Const WS_MAXIMIZEBOX = &H10000 '最大化按鈕
'}
'在窗口結構中為指定的窗口設定資訊
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'{
'返回值Long,指定數據的前一個值
'hwnd 欲為其取得資訊的窗口的句柄
'nIndex 請參考GetWindowLong函數的nIndex參數的說明
'dwNewLong 由nIndex指定的窗口資訊的新值
'}
'設定窗體的層次屬性
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'{
'hwnd 窗口手柄。當使用CreateWindowEx函數創建窗口時,窗口由WS_EX_LAYERED指定的值創建;
' 或者窗口已經創建後,由SetWindowLong根據WS_EX_LAYERED指定的值改變。
Public Const WS_EX_LAYERED = &H80000
'crKey 指定顏色值。指向一個COLOR值,該值指定一個透明顏色值,當創建窗口時,窗口將使用該值。
'bAlpha 混合函數值該值。用於描述窗口的不透明度。當bAlpha 值為時,窗口完全透明,
' 當bAlpha值為時,窗口完全不透明。
'dwFlags 動作。這個參數可以取一個或多個值。用它我們可以創建一個不規則的窗體。
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
'}
'系統欄圖示顯示
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, ByVal lpData As NOTIFYICONDATA) As Long
'{
'dwMessage
Public Const NIM_ADD = &H0 '添加圖示到系統欄提示區
Public Const NIM_DELETE = &H2 '刪除托盤中的圖示
Public Const NIM_MODIFY = &H1 '修改系統狀態列中的圖示
'lpData
Public Const MAX_TOOLTIP As Integer = 64
Public Type NOTIFYICONDATA
cbSize As Long '改變結構所佔地位元組數
hwnd As Long '接受托盤圖示資訊的窗體
uID As Long '為圖示設定的ID
uFlags As Long '設定下面三項是否有效
uCallbackMessage As Long '消息的編號
hIcon As Long '托盤圖示的句柄
szTip As String * MAX_TOOLTIP '滑鼠指到托盤圖示時顯示的提示字元串
End Type
Public nfIconData As NOTIFYICONDATA '定義一個變量nfIconData來記錄設定托盤圖示的數據
Public Const NIF_ICON = &H2 '圖示
Public Const NIF_MESSAGE = &H1 '資訊
Public Const NIF_TIP = &H4 '提示
'滑鼠事件
Public Const WM_MOUSEMOVE = &H200 '在圖示上移動滑鼠
Public Const WM_LBUTTONDOWN = &H201 '滑鼠左鍵按下
Public Const WM_LBUTTONUP = &H202 '滑鼠左鍵釋放
Public Const WM_LBUTTONDBLCLK = &H203 '連續按兩下滑鼠左鍵
Public Const WM_RBUTTONDOWN = &H204 '滑鼠右鍵按下
Public Const WM_RBUTTONUP = &H205 '滑鼠右鍵釋放
Public Const WM_RBUTTONDBLCLK = &H206 '連續按兩下滑鼠右鍵
Public Const WM_SETHOTKEY = &H32 '響應您定義的熱鍵
'}
'穫取*.Ini文件資訊
Public 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
'{
'參數
'lpApplicationName 欲在其中查找條目的小節名稱。這個字串不區分大小寫。如設為vbNullString,就在lpReturnedString緩衝區內裝載這個ini文件所有小節的清單
'lpKeyName 欲穫取的項名或條目名。這個字串不區分大小寫。如設為vbNullString,就在lpReturnedString緩衝區內裝載指定小節所有項的清單
'lpDefault 指定的條目沒有找到時返回的默認值。可設為空("")
'lpReturnedString 指定一個字串緩衝區,長度至少為nSize
'nSize 指定裝載到lpReturnedString緩衝區的最大字元數量
'lpFileName 初始化文件的名字。如沒有指定一個完整路徑名,windows就在Windows目錄中查找文件
'}
'寫入資訊到*.Ini文件
Public 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
'{
'參數
'lpApplicationName 要在其中寫入新字串的小節名稱。這個字串不區分大小寫
'lpKeyName 要設定的項名或條目名。這個字串不區分大小寫。用vbNullString可刪除這個小節的所有設定項
'lpString 指定為這個項寫入的字串值。用vbNullString表示刪除這個項現有的字串
'lpFileName 初始化文件的名字。如果沒有指定完整路徑名,則windows會在windows目錄查找文件。如果文件沒有找到,則函數會創建它
'}
'判斷系統中存在哪些邏輯驅動器字母
Public Declare Function GetLogicalDrives Lib "kernel32" () As Long
'{
'返回值
'Long,這個結構中的二進制位標志著存在哪些驅動器。其中,位設為表示驅動器A:存在於系統中
'}
'判斷一個磁碟驅動器的類型
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'{
'nDrive 包含了驅動器根目錄路徑的一個字串
'返回值
'如驅動器不能識別,則返回零。如指定的目錄不存在,則返回.
'如執行成功,則用下述任何一個常數指定驅動器類型:
Public Const DRIVE_CDROM = 5 'CD-ROM驅動器
Public Const DRIVE_FIXED = 3 '固定驅動器
Public Const DRIVE_RAMDISK = 6 '記憶體驅動器
Public Const DRIVE_REMOTE = 4 '網路驅動器
Public Const DRIVE_REMOVABLE = 2 '可移動驅動器
'}
'穫取與一個磁碟卷有關的資訊
Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, ByVal lpVolumeSerialNumber As Long, ByVal lpMaximumComponentLength As Long, ByVal lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
'{
'參數表
'lpRootPathName 欲穫取資訊的那個卷的根路徑
'lpVolumeNameBuffer 用於裝載卷名(卷標)的一個字串
'nVolumeNameSize lpVolumeNameBuffer字串的長度
'lpVolumeSerialNumber 用於裝載磁碟卷序列號的變量
'lpMaximumComponentLength 指定一個變量,用於裝載檔案名稱每一部分的長度。例如,在“c:\component1\component2.ext”的情況下,它就代表component1或component2名稱的長度
'lpFileSystemFlags 用於裝載一個或多個二進制位標志的變量。對這些標志位的解釋如下:
'
'FS_CASE_IS_PRESERVED 檔案名稱的大小寫記錄於文件系統
'FS_CASE_SENSITIVE 檔案名稱要區分大小寫
'FS_UNICODE_STORED_ON_DISK 檔案名稱保存為Unicode格式
'FS_PERSISTANT_ACLS 文件系統支援文件的訪問控制清單(ACL)安全機制
'FS_FILE_COMPRESSION 文件系統支援逐文件的進行文件壓縮
'FS_VOL_IS_COMPRESSED 整個磁碟卷都是壓縮的
'
'lpFileSystemNameBuffer 指定一個緩衝區,用於裝載文件系統的名稱(如FAT,NTFS以及其他)
'nFileSystemNameSize lpFileSystemNameBuffer字串的長度
'}
'尋找窗口清單中第一個符合指定條件的頂級窗口
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'{
'返回值為找到窗口的句柄。如未找到相符窗口,則返回零。
'參數表
'lpClassName 指向包含了窗口類名的空中止(C語言)字串的指針;或設為零,表示接收任何類
'lpWindowName 指向包含了窗口文本(或標簽)的空中止(C語言)字串的指針;或設為零,表示接收任何窗口標題
'}
'將指針限制到指定區域
Public Declare Function ClipCursor& Lib "user32" (ByVal lpRect As RECT)
'{
'參數表
'lpRect RECT 指定一個矩形,用像素螢幕坐標系統表示,滑鼠指針必須在這個區域內運動。
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
'}
'穫得整個窗口的範圍矩形,窗口的邊框、標題列、卷軸及菜單等都在這個矩形內
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As RECT) As Long
'{
'參數表
'hwnd 想穫得範圍矩形的那個窗口的句柄
'lpRect RECT 螢幕坐標中隨同窗口裝載的矩形
'}
'取得一個矩形,用於描述目前為滑鼠指針規定的剪下來區域;該區域是由SetClipCursor函數定義的
Public Declare Function GetClipCursor Lib "user32" (ByVal lprc As RECT) As Long
'{
'參數表
'lprc RECT 在螢幕坐標系統中隨同目前剪下來矩形載入的一個矩形。
' 倘若沒有活動的剪下來,這個矩形會反映出整個顯示螢幕的大小
'}
'設定指針的位置
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'{
'參數表
'x,y 滑鼠指針在螢幕像素坐標系統中的X,Y位置
'}
'穫得代表整個螢幕的一個窗口(桌面窗口)句柄
Public Declare Function GetDesktopWindow Lib "user32" () As Long
'{
'返回值Long,桌面窗口的句柄
'}
'控制滑鼠的顯示
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
'{
'參數
'bShow TRUE(非零)顯示指針,FALSE隱藏
'}
'設定某一機碼的健值
Public 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
'{
'參數
'hKey 一個已打開項的句柄,或指定一個標準項名
'lpSubKey 欲對它的值進行設定的一個子項的名字。如指定vbNullString,表示設定hKey的默認值
' 如指定的子項不存在,則會創建它
'dwType 必須是REG_SZ
'lpData 新值
'cbData 指定lpData的長度,不包括空中止字元
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
'}
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As Any, ByVal cbData As Long) As Long
'{
'參數
'hKey Long,一個已打開項的句柄,或指定一個標準項名
'lpValueName String,要設定值的名字
'Reserved Long,未用,設為零
'dwType Long,要設定的數量類型
'lpData Any,包含數據的緩衝區中的第一個位元組
'cbData Long,lpData緩衝區的長度
'}
'創建一個機碼
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal phkResult As Long) As Long
'{
'參數
'hKey 要打開項的句柄,或者一個標準項名
'lpSubKey 欲創建的新子項。可同時創建多個項,只需用反斜杠將它們分隔開即可。例如level1\level2\newkey
'phkResult 指定一個變量,用於裝載新子項的句柄
'}
'關閉對註冊表機碼的操作
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'{
'參數
'hKey 要關閉的項
'}
'刪除指定項下方的一個值
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
'{
'參數
'hKey Long,一個已打開項的句柄,或標準項名之一
'lpValueName String,要刪除的值名。可設為vbNullString或一個空串,表示刪除那個項的默認值
'}
'打開一個現有的註冊表項
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal phkResult As Long) As Long
'{
'參數
'hKey Long,一個已打開項的句柄,或指定一個標準項名
'lpSubKey String,要打開的項名
'phkResult Long,指定一個變量,用於裝載(保存)打開註冊表項的一個句柄
'}
'----------------------- 自定義函數 -----------------------
'穫取*.Ini文件資訊
Function GetFromIni(ByVal sSection As String, ByVal sKey As String, ByVal sDefault As String, ByVal sFileName As String) As String
Dim rs As String
rs = String(255, " ")
GetPrivateProfileString(sSection, sKey, sDefault, rs, Len(rs) - 1, sFileName)
rs = left(rs, InStr(rs, Chr(0)) - 1)
GetFromIni = rs
End Function
'寫入資訊到*.Ini文件
Function WriteToIni(ByVal sSection As String, ByVal sKey As String, ByVal sValue As String, ByVal sFileName As String)
WritePrivateProfileString(sSection, sKey, sValue, sFileName)
End Function
'加密字元串
Function Encrypt(ByVal PlainStr As String, ByVal Key As String) As String
Dim n As Integer, every As Integer, word As Integer, pwd As String
For n = 1 To Len(PlainStr)
every = Asc(Mid(PlainStr, n, 1)) + n
word = every + Key
pwd = pwd & word
Next n
Encrypt = pwd
End Function
'解密字元串
Function Decrypt(ByVal PlainStr As String, ByVal Key As String) As String
Dim n As Integer, every As Integer, word As Integer, pwd As String
For n = 1 To Len(PlainStr)
every = Asc(Mid(PlainStr, n, 1))
word = (every + Key) - n
pwd = pwd & word
Next n
Decrypt = pwd
End Function
'根據字元串本身,形成密鑰
Function SecretKey(ByVal souKey As String) As Integer
Dim n As Integer, every As Integer, word As Integer
n = 1
word = Asc(Mid(souKey, n, 1))
For n = 2 To Len(souKey)
every = Asc(Mid(souKey, n, 1))
word = word Xor every
Next n
SecretKey = word
End Function
'將邏輯驅動器的二進制數據轉換為盤符數據
Function BinToWord(ByVal souBin As String) As String
Dim num As Integer, n As Integer, rs As String, every As String
n = 1
For num = Len(souBin) To 1 Step -1
every = Mid(souBin, num, 1)
If every = 1 Then
rs = rs & Chr(65 - 1 + n)
End If
n = n + 1
Next num
BinToWord = rs
End Function
'將十進制轉換為二進制
Function DecToBin(ByVal souDec As Long) As String
Dim numMod As Integer, numLeft As Long, rs As String
Do
numMod = souDec Mod 2
numLeft = souDec \ 2
rs = numMod & rs
souDec = numLeft
Loop Until (souDec = 0)
DecToBin = rs
End Function
'穫得邏輯驅動器的序列號
Function GetDriverSn(ByVal strDriver As String) As String
Dim strLabel As String
Dim lSerialnum As Long
Dim strType As String
GetVolumeInformation(strDriver, strLabel, Len(strLabel), lSerialnum, 0, 0, strType, Len(strType))
GetDriverSn = Hex(lSerialnum)
End Function
'判斷指定類或窗體是否存在
Function IsProcessOrForm(ByVal sClass As String, ByVal sCaption As String) As Boolean
Dim winHwnd As Long
winHwnd = FindWindow(sClass, sCaption)
If winHwnd = 0 Then
IsProcessOrForm = False
Else
IsProcessOrForm = True
End If
End Function
'查找指定窗體
Function ScanWindow(ByVal sCaption As String) As Boolean
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, sCaption)
If winHwnd = 0 Then
ScanWindow = False
Else
ScanWindow = True
End If
End Function
'----------------------- 自定義過程 -----------------------
'將窗體置於螢幕中央
Public Sub FormCenter(ByVal souForm As Form)
souForm.left = (Screen.Width - souForm.Width) / 2
souForm.top = (Screen.Height - souForm.Height) * (1 - User_Golden)
End Sub
'將窗體最大化整個螢幕
Public Sub FormMax(ByVal souForm As Form)
souForm.top = 0
souForm.left = 0
souForm.Height = Screen.Height
souForm.Width = Screen.Width
End Sub
'將窗體置於頂端
Public Sub FormOnTop(ByVal souForm As Form)
SetWindowPos(souForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub
'窗體的半透明化處理
Public Sub Translucence(ByVal souForm As Form, ByVal Degree As Integer)
Dim rtn As Long
rtn = GetWindowLong(souForm.hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong(souForm.hwnd, GWL_EXSTYLE, rtn)
SetLayeredWindowAttributes(souForm.hwnd, 0, Degree, LWA_ALPHA)
End Sub
'在系統欄裏添加圖示
Public Sub TrayAddIcon(ByVal souForm As Form, ByVal ToolText As String)
With nfIconData
.hwnd = souForm.hwnd
.uID = souForm.Icon
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = souForm.Icon.Handle
.szTip = ToolText & vbNullChar
.cbSize = Len(nfIconData)
End With
Call Shell_NotifyIcon(NIM_ADD, nfIconData)
End Sub
'把系統欄中的圖示刪除
Public Sub TrayDelIcon()
Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
End Sub
'將滑鼠限制在ctl區域內
Public Sub ClipToControl(ByVal ctl As Object)
Dim hwnd As Long
Dim t As RECT
hwnd = ctl.hwnd
GetWindowRect(hwnd, t)
SetCursorPos(t.left + (t.right - t.left) / 2, t.top + (t.bottom - t.top) / 2)
ClipCursor(t)
End Sub
'解除對滑鼠移動的限制
Public Sub ClipToDesktop()
Dim t As RECT
GetWindowRect(GetDesktopWindow(), t)
ClipCursor(t)
End Sub
'隱藏滑鼠
Public Sub HideMouse()
ShowCursor(0)
End Sub
'顯示滑鼠
Public Sub ShowMouse()
ShowCursor(1)
End Sub
'將程式加入自動運行
Public Sub RegAddAutorun(ByVal regName As String, ByVal regData As String)
Dim regHand As Long
Dim appFileName As String
appFileName = App.Path & "\lockmanagement.exe"
RegOpenKey(HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentVersion\run", regHand)
RegSetValueEx regHand, regName, 0, REG_SZ, ByVal regData, Len(regData)
RegCloseKey(regHand)
End Sub
'解除程式的自動運行
Public Sub RegRemoveAutorun(ByVal regName As String)
Dim regHand As Long
RegOpenKey(HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentVersion\run", regHand)
RegDeleteValue(regHand, regName)
RegCloseKey(regHand)
End Sub
上一篇:如何用VB穫得機器的MAC地址
下一篇:自制IE風格按紐控件