by Joseph Cartagenas (1 Submission)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sun 19th June 2005
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
'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
No comments have been posted about Collection of class that control your computer such as shutdown, logoff, open and close cd rom and . Why not be the first to post a comment about Collection of class that control your computer such as shutdown, logoff, open and close cd rom and .
