• Home
 · 
• Miscellaneous
 · 
• Collection of class that control your computer such as shutdown, logoff, open and close cd rom and

Collection of class that control your computer such as shutdown, logoff, open and close cd rom and

Collection of class that control your computer such as shutdown, logoff, open and close cd rom and also manipulating database open connection,

API Declarations


Public SQLState As Boolean
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
Private Const LB_FINDSTRING = &H18F
Private Const RGN_OR = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const API_SUCCESS = 0
Private Const KEY_QUERY_VALUE = &H1
Private Const REG_SZ = 1 ' Unicode nul terminated String
Private Const REG_DWORD = 4 ' 32-bit number

Enum SHUTDOWN_TYPE
EWX_LogOff = 0
EWX_SHUTDOWN = 1
EWX_REBOOT = 2
End Enum

Enum HKEY_TYPE
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
End Enum
Private Const ERROR_SUCCESS = 0&
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2

Private Const WM_MOUSEMOVE = &H200

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Const HWND_TOPMOST& = -1

Private Const SWP_NOMOVE& = &H2
Private Const SWP_NOSIZE& = &H1

Private 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

Private myData As ADODB.Connection 'object variable to set the connection to the database
Private myCommand As ADODB.Command 'object variable to set command to the database
Private myTable As ADODB.Recordset 'object variable to set recordset to the database
Private nid As NOTIFYICONDATA

'API call declaration
Private 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
Private 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
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private 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
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
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 Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function ShowCursor& Lib "user32" (ByVal bShow As Long)
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
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpValueName As String) As Long
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 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
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 Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Private 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




Rate Collection of class that control your computer such as shutdown, logoff, open and close cd rom and

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

    'set the two object variable
    Set myCommand = New ADODB.Command
    Set myData = New ADODB.Connection
End Sub

Private Sub Class_Terminate()
    'remove the two object variable from the memory
    Set myCommand = Nothing
    Set myData = Nothing
End Sub
Public Sub OpenConnection(con As String)
    'a function to open the connection on a given parameter
    myData.Open con
End Sub
Public Sub CloseConnection()
    myData.Close
End Sub
Public Function RunStoredProcedure(sp As String, Optional param As Variant) As ADODB.Recordset
On Error GoTo mali
    myCommand.CommandType = adCmdStoredProc
    myCommand.CommandText = sp
    Set myCommand.ActiveConnection = myData
    Set RunStoredProcedure = myCommand.Execute(adAsyncExecute, param)
    Set param = Nothing
    Exit Function
mali:
    SaveErrorLog "MilkFish", "General", "RunsStoredProcedure", Err.Description
End Function

Public Function CountData(tb As String) As Long
On Error GoTo mali
    'a function to return the number of data in a database
    Dim rsCount As ADODB.Recordset
    Set rsCount = myData.Execute("SELECT Count(*) AS rCount FROM " & tb)
    CountData = rsCount.Fields("rCount")
    Set rsCount = Nothing
mali:
End Function

Public Function OpenTable(cmdTxt As String, cmdType As CommandTypeEnum, Optional curType As CursorTypeEnum, Optional cLock As LockTypeEnum) As ADODB.Recordset
On Error GoTo mali
    curType = IIf(Trim(curType) = 0, adOpenKeyset, curType)
    cLock = IIf(Trim(cLock) = 0, adLockOptimistic, cLock)
    Set myTable = New ADODB.Recordset
    Set myCommand = New ADODB.Command
    myCommand.ActiveConnection = myData
    myCommand.CommandText = cmdTxt
    myCommand.CommandType = cmdType
    Set myTable.Source = myCommand
    myTable.CursorType = curType
    myTable.LockType = cLock
    myTable.Open
    Set OpenTable = myTable
    Exit Function
mali:
    SaveErrorLog "MilkFish", "General", "RunsStoredProcedure", Err.Description
End Function

Public Function FloodData(obj As Object, tb As String, fd As String)
On Error GoTo mali
    Dim mySet As ADODB.Recordset
    Set mySet = New ADODB.Recordset
    mySet.Open tb, myData, adOpenForwardOnly, adLockOptimistic
    If mySet.EOF = False And mySet.BOF = False Then
        obj.Clear
        Do
            DoEvents
            obj.AddItem mySet.Fields(fd)
            mySet.MoveNext
        Loop Until mySet.EOF
    End If
    mySet.Close
    Exit Function
mali:
End Function

Public Sub PlaySound(fName As String, flags As Long)
    sndPlaySound fName, flags
End Sub

Public Sub ViewTaskBar(lbValue As Boolean)
    Dim llResult As Long
    llResult = FindWindow("Shell_traywnd", "")
    If lbValue Then
        llResult = SetWindowPos(llResult, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
    Else
        llResult = SetWindowPos(llResult, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
    End If
End Sub

Public Sub DisableCTRLaltDEL(bVal As Boolean)
    Dim lReturn  As Long
    Dim lBool As Long
    lReturn = SystemParametersInfo(97, bVal, lBool, vbNull)
End Sub

Public Sub ShutDownWindows(ByVal uFlags As SHUTDOWN_TYPE)
    ExitWindowsEx uFlags, 0&
End Sub

Public Sub QuickSearch(obj As Object, fValue As String)
   obj.ListIndex = SendMessage(obj.hwnd, LB_FINDSTRING, -1, ByVal CStr(fValue))
End Sub

Public Sub ThreeDForm(frmForm As Object)
    Const cPi = 3.1415926
    Dim intLineWidth As Integer
    intLineWidth = 5
    ' 'save scale mode
    Dim intSaveScaleMode As Integer
    intSaveScaleMode = frmForm.ScaleMode
    frmForm.ScaleMode = 3
    Dim intScaleWidth As Integer
    Dim intScaleHeight As Integer
    intScaleWidth = frmForm.ScaleWidth
    intScaleHeight = frmForm.ScaleHeight
    ' 'clear form
    frmForm.Cls
    ' 'draw white lines
    frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF
    frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF
    ' 'draw grey lines
    frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, intScaleHeight), &H808080, BF
    frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, intScaleHeight), &H808080, BF
    ' 'draw triangles(actually circles) at corners
    Dim intCircleWidth As Integer
    intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth)
    frmForm.FillStyle = 0
    frmForm.FillColor = QBColor(15)
    frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), intCircleWidth, QBColor(15), _
    -3.1415926, -3.90953745777778 '-180 * cPi / 180, -224 * cPi / 180
    frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), intCircleWidth, QBColor(15), _
    -0.78539815, -1.5707963 ' -45 * cPi / 180, -90 * cPi / 180
    ' 'draw black frame
    frmForm.Line (0, intScaleHeight)-(0, 0), 0
    frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0
    frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0
    frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0
    frmForm.ScaleMode = intSaveScaleMode
End Sub

Public Sub StayOnTop(Form As Object)
    Dim lFlags As Long
    Dim lStay As Long

    lFlags = SWP_NOSIZE Or SWP_NOMOVE
    lStay = SetWindowPos(Form.hwnd, HWND_TOPMOST, 0, 0, 0, 0, lFlags)
End Sub

Public Sub MenuLine(frm As Object)
    frm.Line (0, 0)-(Screen.Width, 0), &H80000003
    frm.Line (0, Screen.TwipsPerPixelX)-(Screen.Width, Screen.TwipsPerPixelX), &H80000006
End Sub

Public Sub OpenCDROM()
    'use this to open the cd-rom
    Dim lngReturn As Long
    Dim strReturn As Long
    lngReturn = mciSendString("set CDAudio door open", strReturn, 127, 0)
End Sub
Public Sub CloseCDROM()
    'use this to close the cd-rom
    Dim lngReturn As Long
    Dim strReturn As Long
    lngReturn = mciSendString("set CDAudio door closed", strReturn, 127, 0)
End Sub
Public Sub HideApplication(bShow As Boolean)
    App.TaskVisible = bShow
End Sub
 
Public Sub ShowDekstopIcon()
    Dim hwnd As Long
    hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
    ShowWindow hwnd, 5
End Sub
Public Sub HideDekstopIcon()
    Dim hwnd As Long
    hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
    ShowWindow hwnd, 0
End Sub

Public Sub ShowMouse(bShow As Boolean)
    ShowCursor bShow
End Sub
Public Function ConvertSingleQuote(yourString As String) As String
    ConvertSingleQuote = Replace(yourString, "'", Chr(146))
End Function
Public Function Parse(sString, tbname As String, fldname As String)
    '--------------------------------------------------------
    'condo +"by the sea" +beach -expensive
    'function converts search string (like in Altavista) into
    'SQL query string for database search
    '
    'To make this work in your database, you need to
    'replace "table" and "field" with appropriate values
    '--------------------------------------------------------
    
    Dim iBlank As Integer       'first iBlank space position
    Dim iNextBlank As Integer   'Next iBlank space position (d)
    Dim iCount As Integer       'iCount variable
    Dim sFirstLeft  As String   'first character following iBlank
    Dim sSecondLeft As String   'first character following sFirstLeft
    Dim sSQLStmt As String      'SQL statement
    Dim sWord As String         'each Word within string
    Dim sPhrase As String       'Phrase within quotations
    Dim sChars As String        'All chars. Used for error checking.
    Dim bAnyChars As Boolean    'Is there any alpha and num characters in sString
                                'Used for error checking.
    
    'Begin Error checking
    sChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
    bAnyChars = False
    For iCount = 1 To 36
        If InStr(1, UCase(sString), Mid(sChars, iCount, 1)) <> 0 Then
            bAnyChars = True
        End If
    Next iCount
    If Not bAnyChars Then Exit Function
    'End Error checking
    
    sString = Chr(32) & Trim(sString) & Chr(32)
    iCount = 0
    iBlank = 0
    sSQLStmt = "SELECT * FROM " & tbname & " WHERE"
      
    Do While InStr(sString, Chr(32)) <> 0
        iBlank = InStr(sString, Chr(32))
        
        If iBlank = 0 Then
            sFirstLeft = Mid(sString, iBlank, 1)
            sSecondLeft = Mid(sString, iBlank + 1, 1)
        Else
            sFirstLeft = Mid(sString, iBlank + 1, 1)
            sSecondLeft = Mid(sString, iBlank + 2, 1)
        End If
        
        iNextBlank = InStr(iBlank + 1, sString, Chr(32))
        
        If sFirstLeft = """" Then
            sWord = Mid(sString, InStr(iBlank, sString, Chr(34)) + 1, InStr(iBlank + 2, sString, Chr(34)) - 3)
            iNextBlank = InStr(iBlank + 2, sString, Chr(34)) + 1
        Else
            If sSecondLeft = """" Then
                sWord = Chr(32) & Chr(32) & Mid(sString, InStr(iBlank, sString, Chr(34)) + 1, InStr(iBlank + 4, sString, Chr(34)) - 4)
                iNextBlank = InStr(iBlank + 4, sString, Chr(34)) + 1
            Else
                sWord = Mid(sString, 1, InStr(iBlank + 2, sString, Chr(32)))
            End If
        End If

        Select Case sFirstLeft
            Case "+":
                If iCount <> 0 Then sSQLStmt = sSQLStmt & " AND"
                sSQLStmt = sSQLStmt & " " & fldname & " LIKE '%"
                sSQLStmt = sSQLStmt & Trim(Mid(sWord, 3))
                sSQLStmt = sSQLStmt & "%'"
            Case "-":
                If iCount <> 0 Then sSQLStmt = sSQLStmt & " AND"
                sSQLStmt = sSQLStmt & " " & fldname & " NOT LIKE '%"
                sSQLStmt = sSQLStmt & Trim(Mid(sWord, 3))
                sSQLStmt = sSQLStmt & "%'"
            Case Chr(32), "":
                sSQLStmt = sSQLStmt
            Case Is <> "+", "-", Chr(32):
                If iCount <> 0 Then sSQLStmt = sSQLStmt & " OR"
                sSQLStmt = sSQLStmt & " " & fldname & " LIKE '%"
                sSQLStmt = sSQLStmt & Trim(sWord)
                sSQLStmt = sSQLStmt & "%'"
        End Select
        
        iCount = iCount + 1
        sString = Right(sString, Len(sString) - iNextBlank + 1)
        
        If sFirstLeft = "" Then
            Exit Do
        End If
    Loop
       
    Parse = sSQLStmt
End Function

Public Sub DisabledKeyboard(Disabled_Enabled As Boolean)
    If Disabled_Enabled Then
        Shell "rundll32.exe keyboard,disable", vbNormalFocus
    Else
        Shell "rundll32.exe keyboard,enable", vbNormalFocus
    End If
End Sub

Public Sub DisabledMouse(Disabled_Enabled As Boolean)
'    If Disabled_Enabled Then
'        Shell "rundll32.exe mouse,disable", vbNormalFocus
'    Else
'        Shell "rundll32.exe mouse,enable", vbNormalFocus
'    End If
    ShowCursor Disabled_Enabled
End Sub

Public Function WriteProfile(lpApplicationName As String, lpKeyName As String, lpString As String, lpFileName As String) As Long
    WriteProfile = WritePrivateProfileString(lpApplicationName, lpKeyName, lpString, lpFileName)
End Function

Public Function GetProfile(lpApplicationName As String, lpKeyName As String, lpDefault As String, lpReturnedString As String, nSize As Long, lpFileName As String) As Long
    GetProfile = GetPrivateProfileString(lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName)
End Function
Public Sub About()
    MsgBox "Created by Joseph Cartagenas"
End Sub

Public Function SkinForm(picSkin As Object) As Long
On Error GoTo mali
    ' Make a windows "region" based on a given picture box'
    ' picture. This done by passing on the picture line-
    ' by-line and for each sequence of non-transparent
    ' pixels a region is created that is added to the
    ' complete region.
    
    Dim X As Long, Y As Long, StartLineX As Long
    Dim FullRegion As Long, LineRegion As Long
    Dim TransparentColor As Long
    Dim InFirstRegion As Boolean
    Dim InLine As Boolean  ' Flags whether we are in a non-tranparent pixel sequence
    Dim hDC As Long
    Dim PicWidth As Long
    Dim PicHeight As Long
    
    hDC = picSkin.hDC
    PicWidth = picSkin.ScaleWidth
    PicHeight = picSkin.ScaleHeight
    
    InFirstRegion = True: InLine = False
    X = Y = StartLineX = 0
    
    ' The transparent color is always the color of the
    ' top-left pixel in the picture. If you wish to
    ' bypass this constraint, you can set the tansparent
    ' color to be a fixed color (such as pink), or
    ' user-configurable
    TransparentColor = GetPixel(hDC, 0, 0)
    
    For Y = 0 To PicHeight - 1
        For X = 0 To PicWidth - 1
            
            If GetPixel(hDC, X, Y) = TransparentColor Or X = PicWidth Then
                ' We reached a transparent pixel
                If InLine Then
                    InLine = False
                    LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)
                    
                    If InFirstRegion Then
                        FullRegion = LineRegion
                        InFirstRegion = False
                    Else
                        CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
                        ' Always clean up your mess
                        DeleteObject LineRegion
                    End If
                End If
            Else
                ' We reached a non-transparent pixel
                If Not InLine Then
                    InLine = True
                    StartLineX = X
                End If
            End If
        Next
    Next
    SkinForm = FullRegion
    Exit Function
mali:
    MsgBox "System Internal Error. " & Err.Description, vbExclamation
End Function

Private Sub SetWindow(hwnd As Long, hRgn As Long, bRedraw As Boolean)
    SetWindowRgn hwnd, hRgn, bRedraw
End Sub

Public Sub DragForm(frm As Object)
      ReleaseCapture
      SendMessage frm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

Public Function MakeStartUp(fName As String, strName As String)
    Call SaveString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", strName, fName)
End Function

Public Function DeleteStartUp(fName As String, strName As String)
    Call DeleteValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", strName)
End Function

Public Sub SaveString(hkey As HKEY_TYPE, strPath As String, strValue As String, strData As String)
    Dim keyHand As Long, r As Long
    r = RegCreateKey(hkey, strPath, keyHand)
    r = RegSetValueEx(keyHand, strValue, 0, REG_SZ, ByVal strData, Len(strData))
    r = RegCloseKey(keyHand)
End Sub

Public Function DeleteValue(ByVal hkey As HKEY_TYPE, ByVal strPath As String, ByVal strValue As String)
    Dim keyHand As Long, r As Long
    r = RegOpenKey(hkey, strPath, keyHand)
    r = RegDeleteValue(keyHand, strValue)
    r = RegCloseKey(keyHand)
End Function

Public Function GetString(hkey As HKEY_TYPE, strPath As String, strValue As String)
    Dim keyHand As Long, dataType As Long
    Dim lResult As Long, strBuf As String
    Dim lDataBufSize As Long, intZeroPos As Integer
    Dim r As Long, lValueType As Long
    r = RegOpenKey(hkey, strPath, keyHand)
    lResult = RegQueryValueEx(keyHand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
    If lValueType = REG_SZ Then
        strBuf = String(lDataBufSize, " ")
        lResult = RegQueryValueEx(keyHand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
        If lResult = ERROR_SUCCESS Then
            intZeroPos = InStr(strBuf, Chr$(0))
            If intZeroPos > 0 Then
                GetString = Left$(strBuf, intZeroPos - 1)
            Else
                GetString = strBuf
            End If
        End If
    End If
End Function

Public Function GetDword(ByVal hkey As HKEY_TYPE, ByVal strPath As String, ByVal strValueName As String) As Long
    Dim lResult As Long, lValueType As Long
    Dim lBuf As Long, lDataBufSize As Long
    Dim r As Long, keyHand As Long
    r = RegOpenKey(hkey, strPath, keyHand)
    lDataBufSize = 4
    lResult = RegQueryValueEx(keyHand, strValueName, 0&, lValueType, lBuf, lDataBufSize)
    If lResult = ERROR_SUCCESS Then
        If lValueType = REG_DWORD Then
            GetDword = lBuf
        End If
    End If
    r = RegCloseKey(keyHand)
End Function

Public Function SaveDword(ByVal hkey As HKEY_TYPE, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
    Dim lResult As Long, keyHand As Long, r As Long
    r = RegCreateKey(hkey, strPath, keyHand)
    lResult = RegSetValueEx(keyHand, strValueName, 0&, REG_DWORD, lData, 4)
    r = RegCloseKey(keyHand)
End Function

Private Function GetRegString(lRegRoot As Long, sRegKey As String, sSubKey As String) As String
    Dim hRegKey As Long
    Dim lResult As Long
    Dim lValueSize As Long
    Dim lValueType As Long
    Dim sTempStr As String
    Const REG_SZ = 1
    
    GetRegString = ""
    lResult = RegOpenKeyEx(lRegRoot, sRegKey, 0&, KEY_QUERY_VALUE, hRegKey)
    
    If lResult = API_SUCCESS Then
        lResult = RegQueryValueEx(hRegKey, sSubKey, 0&, lValueType, ByVal 0&, lValueSize)
        If lValueType = REG_SZ Then
            sTempStr = String(lValueSize, " ")
            lResult = RegQueryValueEx(hRegKey, sSubKey, 0&, 0&, ByVal sTempStr, lValueSize)
    
            If lResult = API_SUCCESS Then
                GetRegString = Left$(sTempStr, InStr(sTempStr, vbNullChar) - 1)
            End If
        End If
        lResult = RegCloseKey(hRegKey)
    End If
End Function

Public Sub AddIconTray(frm As Object, msgTip As String)
    'Set the individual values of the NOTIFYICONDATA data type.
    nid.cbSize = Len(nid)
    nid.hwnd = frm.hwnd
    nid.uId = vbNull
    nid.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    nid.uCallBackMessage = WM_MOUSEMOVE
    nid.hIcon = frm.Icon
    nid.szTip = msgTip & vbNullChar
    'Call the Shell_NotifyIcon function to add the icon to the taskbar
    'status area.
    Shell_NotifyIcon NIM_ADD, nid
End Sub

Public Sub DeleteIconTray()
    Shell_NotifyIcon NIM_DELETE, nid
End Sub
Public Function RunSQL(strSQL As String) As ADODB.Recordset
On Error GoTo mali
    myCommand.CommandText = strSQL
    myCommand.CommandType = adCmdText
    Set myCommand.ActiveConnection = myData
    Set RunSQL = myCommand.Execute
    SQLState = True
    Exit Function
mali:
    MsgBox Err.Description, vbExclamation
    SQLState = False
End Function

Public Sub SelectText(obj As Object)
    obj.SelStart = 0
    obj.SelLength = Len(obj.Text)
End Sub

Public Sub ClearText(objFrm As Form)
    Dim i As Long
    For i = 0 To objFrm.Count - 1
        If (TypeOf objFrm.Controls(i) Is TextBox) Then
            objFrm.Controls(i).Text = ""
        End If
    Next i
End Sub

Public Function CheckEntry(objFrm As Form) As Boolean
    Dim i As Long
    Dim bolValue As Boolean
    For i = 0 To objFrm.Count - 1
        If (TypeOf objFrm.Controls(i) Is TextBox) Then
            If objFrm.Controls(i).Text = "" Then
                bolValue = True
            End If
        End If
    Next i
    CheckEntry = bolValue
End Function

Function ValidateEntry(strValid As String, kAscii As Integer) As Integer
On Error GoTo mali
    If kAscii > 26 Then
       If InStr(strValid, Chr(kAscii)) = 0 Then
          ValidateEntry = 0
       Else
          ValidateEntry = -1
       End If
    Else
       ValidateEntry = -1
    End If
mali:
End Function

Function ConnectionState() As Boolean
    If myData.State = 1 Then
        ConnectionState = True
    Else
        ConnectionState = False
    End If
End Function
Sub BeginTransaction()
    myData.BeginTrans
End Sub

Sub CommitTransaction()
    myData.CommitTrans
End Sub

Sub RollbackTransaction()
    myData.RollbackTrans
End Sub

Sub SaveErrorLog(frm As String, obj As String, evnt As String, desc As String)
On Error GoTo mali
    Dim FileName As Integer
    FileName = FreeFile
    If Dir(App.Path & "\error.log") <> "" Then
        Open App.Path & "\error.log" For Append As #FreeFile
        Write #FileName, frm & ";" & obj & ";" & evnt & ";" & desc & ";"; Now
    Else
        Open App.Path & "\error.log" For Output As #FreeFile
    End If
    Close #FileName
    Exit Sub
mali:
    SaveErrorLog "Class Modules", "", "SaveErrorLog", Err.Description
End Sub