資訊好好玩

0愛的鼓勵 0訂閱站台

透過我的多次實踐，在編寫了許多軟體的基礎上，我自編和整合了許多較實用的函數。
注意，以下代碼前半部分為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