Attribute VB_Name = "MiscFunctions" Option Explicit 'Following are for CRC functions. Const Polynomial16 As Integer = &HA001 Const Polynomial32 As Long = &HEDB88320 'e.g. Call next two lines as "Hex(CRCxx([string]))" to return a hex text string. 'Function CRC16(ByVal S As String) As Integer 'Returns CRC-16 for string "S". 'Function CRC32(ByVal S As String) As Integer 'Returns CRC-32 for string "S". Const KEY_RIGHTS = &HF003F '((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) Const E_UNEXPECTED = &H8000FFFF Public Const KEY_CURRENT_USER = &H80000001 Public Const KEY_LOCAL_MACHINE = &H80000002 'Note: Following two lines go in application. 'Const KEY_SCOPE = xxx 'select KEY_CURRENT_USER or KEY_LOCAL_MACHINE. 'Const KEY_PATH = "SOFTWARE\SD\TheAppName" 'the key name (AKA subkey path). 'Following are to read, write and delete Registry subkeys: (return true if sucess). 'Function KeyGet (KeyScope, KeyPath, KeyName, KeyValue) 'to retreive a subkey. 'Function KeySave(KeyScope, KeyPath, KeyName, KeyValue) 'to save or make a subkey. 'Function KeyDelete(KeyScope, KeyPath, KeyName) 'to delete a subkey. Public Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long Public Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long Public 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 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, lpData As Any, ByVal cbData As Long) As Long Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Public Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long 'Following is to determine scroll lock status. 'Function ScrollLockState() As Boolean 'Returns Scroll Lock light state. Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer 'Following are for display count and desktop (virtual screen) size. 'e.g. "GetSystemMetrics(SM_CXVIRTUALSCREEN) / Screen.TwipsPerPixelX" is total displays width. Public Const SM_CXVIRTUALSCREEN = 78 'the width of the virtual screen, in pixels. Public Const SM_CYVIRTUALSCREEN = 79 'the height of the virtual screen, in pixels. Public Const SM_CMONITORS = 80 'the number of display monitors on the desktop. Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long 'Following shows and hides cursor - be careful, read up on it first or you may lose the cursor! Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long 'Following brings a window to the top, AKA zorder. Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long 'call with "SetForegroundWindow FrmMain.hwnd" Public Function DisplaysWidth() 'Return total width of all displays. DisplaysWidth = GetSystemMetrics(SM_CXVIRTUALSCREEN) * Screen.TwipsPerPixelX End Function Public Function DisplaysHeight() 'Returns total height of all displays. DisplaysHeight = GetSystemMetrics(SM_CYVIRTUALSCREEN) * Screen.TwipsPerPixelY End Function Public Function KeyDelete(ByVal KeyScope As Long, ByVal KeyPath As String, _ ByVal KeyName As String) As Boolean ' Written by Kenneth Ives kenaso@home.com 'Deletes a subkey value from Registry. 'ENTER: 'KeyScope = Registry type (HKEY_SCOPE = &H80000001, HKEY_LOCAL_MACHINE = &H80000002), 'KeyPath = Registry Key path (e.g. "SOFTWARE\SD\Daily"), 'KeyName = Registry SubKey Name (e.g. "Last Run"), 'RETURNS: True if sucessful, False otherwise. Dim hKey As Long, Txt As String If Not KeyGet(KeyScope, KeyPath, KeyName, Txt) Then Exit Function 'carry on only if key exists. KeyDelete = True If RegOpenKeyEx(KeyScope, KeyPath, 0, &H2003F, hKey) <> 0 Then KeyDelete = False 'get subkey handle. If RegDeleteValue(hKey, KeyName) <> 0 Then KeyDelete = False 'delete the subkey. If RegCloseKey(hKey) <> 0 Then KeyDelete = False 'cleanup. End Function Function RevisionLabel() 'Retruns string with the app's revision number. RevisionLabel = "Rev:" + Trim(Str(App.Major)) + "." _ + Trim(Str(App.Minor)) + "." _ + Trim(Str(App.Revision)) End Function Public Function ScrollLockState() As Boolean 'returns Scroll Lock light state. If GetKeyState(145) = 1 Or GetKeyState(145) = -127 Then ScrollLockState = True Else ScrollLockState = False End If End Function Public Function CRC16(ByVal S As String) As Integer 'Makes CRC-16 for string "S". Dim L As Variant, ICRC As Integer, Bits As Variant ICRC = &HFFFF ' Initialise. Integer maths used. For L = 1 To Len(S) ' Update for each char in S. ICRC = ICRC Xor Asc(Mid(S, L, 1)) For Bits = 0 To 7 Select Case (ICRC And &H1) 'test LSB. Case 0: ICRC = RightShift(ICRC) ' LSB zero, just shift. Case Else: ICRC = RightShift(ICRC) Xor Polynomial16 ' only XOR with polynomial if LSB set. End Select Next Next CRC16 = Abs(ICRC) End Function Public Function CRC32(ByVal S As String) As String 'Makes CRC-32 for string "S". Dim L As Long, LCRC As Long, Bits As Variant LCRC = &HFFFFFFFF ' Initialise, force long math. For L = 1 To Len(S) ' Update for each char in S. LCRC = LCRC Xor Asc(Mid(S, L, 1)) For Bits = 0 To 7 Select Case (LCRC And &H1) 'test LSB. Case 0: LCRC = RightShift(LCRC) ' LSB zero, just shift. Case Else: LCRC = RightShift(LCRC) Xor Polynomial32 ' only XOR with polynomial if LSB set. End Select Next Next LCRC = Not LCRC ' Finally flip all bits, again, part of the CRC-32 protocol. CRC32 = Abs(LCRC) End Function Private Function RightShift(ByVal V) As Long 'Recursive bit shifter for internal CRC use. ' Note no type declaration for V, as a long or integer can be passed. ' Self-explanatory. The final line is essential because the number is signed. Select Case VarType(V) Case vbLong 'FOR CRC-32. RightShift = V And &HFFFFFFFE RightShift = RightShift \ &H2 RightShift = RightShift And &H7FFFFFFF Case Else 'FOR CRC-16. RightShift = V And &HFFFE RightShift = RightShift \ &H2 RightShift = RightShift And &H7FFF End Select End Function Public Function KeyGet(KeyScope As Long, KeyName As String, SubKeyRef As String, _ ByRef KeyVal As String) As Boolean 'Retrieves a subkey value from Registry. 'ENTER: 'KeyScope = Registry type (HKEY_SCOPE = &H80000001, HKEY_LOCAL_MACHINE = &H80000002), 'KeyName = Registry Key path (e.g. "SOFTWARE\SD\Daily"), 'SubRefKey = Registry SubKey Name (e.g. "Last Run"), 'KeyVal = String var with returned subkey value if succesful, otherwise "". 'RETURNS: True if sucessful, False otherwise. Dim i As Long ' Loop Counter Dim rc As Long ' Return Code Dim hKey As Long ' Handle To An Open Registry Key Dim hDepth As Long ' Dim KeyValType As Long ' Data Type Of A Registry Key Dim tmpVal As String ' Tempory Storage For A Registry Key Value Dim KeyValSize As Long ' Size Of Registry Key Variable '------------------------------------------------------------ ' Open RegKey '------------------------------------------------------------ rc = RegOpenKeyEx(KeyScope, KeyName, 0, &H2003F, hKey) ' Open Registry Key If (rc <> 0) Then GoTo GetKeyError ' Handle Error... tmpVal = String(1024, 0) ' Allocate Variable Space KeyValSize = 1024 ' Mark Variable Size '------------------------------------------------------------ ' Retrieve Registry Key Value... '------------------------------------------------------------ rc = RegQueryValueEx(hKey, SubKeyRef, 0, _ KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value If rc <> 0 Or KeyValSize = 0 Then GoTo GetKeyError ' Handle Errors If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String... tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String Else ' WinNT Does NOT Null Terminate String... tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only End If '------------------------------------------------------------ ' Determine Key Value Type For Conversion... '------------------------------------------------------------ Select Case KeyValType ' Search Data Types... Case 1 ' String Registry Key Data Type KeyVal = tmpVal ' Copy String Value Case 4 ' Double Word Registry Key Data Type For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char. Next KeyVal = Format("&h" + KeyVal) ' Convert Double Word To String End Select KeyGet = True ' Return Success rc = RegCloseKey(hKey) ' Close Registry Key Exit Function ' Exit GetKeyError: ' Cleanup After An Error Has Occured... KeyVal = "" ' Set Return Val To Empty String KeyGet = False ' Return Failure rc = RegCloseKey(hKey) ' Close Registry Key End Function Function KeySave(KeyRoot As Long, strKey As String, strValueName As String, _ strValue As String) As Boolean ' Saves a subkey in the registry, makes the [key and] subkey if it doesn't exist. 'ENTER: 'KeyRoot = Registry type (HKEY_SCOPE = &H80000001, HKEY_LOCAL_MACHINE = &H80000002), 'strKey = Registry Key path (e.g. "SOFTWARE\SD\Daily"), 'strValueName = Registry SubKey Name (e.g. "Last Run"), 'strValue = String var with subkey value to save. 'RETURNS: True if sucessful, False otherwise. Dim hKey As Long, cbData As Long On Error GoTo KeySaveError If (RegCreateKeyEx(KeyRoot, strKey, 0, vbNullString, 0, KEY_RIGHTS, 0, hKey, 0)) = 0 Then cbData = LenB(StrConv(strValue, vbFromUnicode)) If RegSetValueEx(hKey, strValueName, 0, 1, ByVal strValue, cbData) <> 0 Then RegCloseKey hKey Err.Raise E_UNEXPECTED End If RegCloseKey hKey KeySave = True Else Err.Raise E_UNEXPECTED End If KeySaveResume: Exit Function KeySaveError: KeySave = False Resume KeySaveResume End Function