Answered by:
Forum for Helpful Visual Basic 6.0 Codes...

Question
-
Hi Friends, I'm starting a new forum on VB6 codes. You all are invited to contribute in it. Put as many codes as possible that can be helpful to everybody.
Waiting for all you guys and gals....Thursday, April 19, 2007 9:52 AM
Answers
-
Thanks Sanket, i was really wanting to have a VB6.0 thread. as many other forums and even MS have discontinued official support for VB6.0
Wish this post a very good luck. Ill also try to post many codes, but after my exams
Thursday, April 19, 2007 9:54 AM -
Various joy stick functions, determine if a joy stick is presentPublic Const JOY_BUTTON1 = &H1
Public Const JOY_BUTTON2 = &H2
Public Const JOY_BUTTON3 = &H4
Public Const JOY_BUTTON4 = &H8
Public Type JOYINFO
X As Long
Y As Long
Z As Long
Buttons As Long
End Type
' Private defs
Private Const JOYERR_BASE = 160
Private Const JOYERR_NOERROR = (0)
Private Const JOYERR_NOCANDO = (JOYERR_BASE + 6)
Private Const JOYERR_PARMS = (JOYERR_BASE + 5)
Private Const JOYERR_UNPLUGGED = (JOYERR_BASE + 7)
Private Const MAXPNAMELEN = 32
Private Type JOYCAPS
wMid As Integer
wPid As Integer
szPname As String * MAXPNAMELEN
wXmin As Long
wXmax As Long
wYmin As Long
wYmax As Long
wZmin As Long
wZmax As Long
wNumButtons As Long
wPeriodMin As Long
wPeriodMax As Long
End Type
Private Declare Function joyGetDevCaps Lib "winmm.dll" _
Alias "joyGetDevCapsA" (ByVal id As Long, _
lpCaps As JOYCAPS, ByVal uSize As Long) As Long
Private Declare Function joyGetNumDevs Lib "winmm.dll" _
() As Long
Private Declare Function joyGetPos Lib "winmm.dll" _
(ByVal uJoyID As Long, pji As JOYINFO) As Long
CodePublic Function GetJoyMin(ByVal joy As Integer, ji As JOYINFO) As Boolean
Dim jc As JOYCAPS
If joyGetDevCaps(joy, jc, Len(jc)) <> JOYERR_NOERROR Then
GetJoyMin = False
Else
ji.X = jc.wXmin
ji.Y = jc.wYmin
ji.Z = jc.wZmin
ji.Buttons = jc.wNumButtons
GetJoyMin = True
End If
End Function
'
' Fills the ji structure with the maximum x, y, and z
' coordinates. Buttons is filled with the number of
' buttons.
'
Public Function GetJoyMax(ByVal joy As Integer, ji As JOYINFO) As Boolean
Dim jc As JOYCAPS
If joyGetDevCaps(joy, jc, Len(jc)) <> JOYERR_NOERROR Then
GetJoyMax = False
Else
ji.X = jc.wXmax
ji.Y = jc.wYmax
ji.Z = jc.wZmax
ji.Buttons = jc.wNumButtons
GetJoyMax = True
End If
End Function
Public Function GetJoystick(ByVal joy As Integer, ji As JOYINFO) As Boolean
If joyGetPos(joy, ji) <> JOYERR_NOERROR Then
GetJoystick = False
Else
GetJoystick = True
End If
End Function
'
' If IsConnected is False then it returns the number of
' joysticks the driver supports. (But may not be connected)
'
' If IsConnected is True the it returns the number of
' joysticks present and connected.
'
' IsConnected is true by default.
'
Public Function IsJoyPresent(Optional IsConnected As Variant) As Long
Dim ic As Boolean
Dim i As Long
Dim j As Long
Dim ret As Long
Dim ji As JOYINFO
ic = IIf(IsMissing(IsConnected), True, CBool(IsConnected))
i = joyGetNumDevs
If ic Then
j = 0
Do While i > 0
i = i - 1 'Joysticks id's are 0 and 1
If joyGetPos(i, ji) = JOYERR_NOERROR Then
j = j + 1
End If
Loop
IsJoyPresent = j
Else
IsJoyPresent = i
End If
End FunctionThursday, April 19, 2007 9:59 AM -
Thanks Harshil for supporting me, and also Best of Luck for your exams.Thursday, April 19, 2007 10:01 AM
-
Reads strings from an INI file
'Reads strings from INI files
Function readstringINI(ini_file As String, ini_section As String, ini_entry As String, default As String) As String
Dim section As String, entry As String
Dim foundsection As Integer
Dim foundentry As Integer
Open ini_file For Input As #1
'Finding the section...
Do While (Not EOF(1)) And (foundsection = 0)
Line Input #1, section
If Left(section, 1) = "[" Then
foundsection = InStr(section, ini_section)
End If
Loop
'Finding the entry...
If foundsection = 0 Then
'MsgBox "Section not found"
Else
Do
Line Input #1, entry
foundentry = InStr(entry, ini_entry)
Loop While (Not EOF(1)) And (foundsection <> 0) And (foundentry = 0) And (Left(entry, 1) <> "[")
'If foundentry = 0 Then MsgBox "Entry not found"
End If
If (foundsection <> 0) And (foundentry <> 0) Then
Dim position As Integer, length As Integer
position = InStr(entry, "=")
length = Len(entry)
position = length - position
readstringINI = Right(entry, position)
Else
readstringINI = default
End If
Close #1
End FunctionThursday, April 19, 2007 10:02 AM -
Code 3 : Makes a string appear on on the active formPrint "I am cool --Sanket T. Shah."
Thursday, April 19, 2007 10:04 AM -
Code 4 : Makes a drawing application similar to paintPrivate Sub cmdClear_Click()
Picture1.Cls
End Sub
Private Sub Form_Load()
drawcol = 12 'use red to start with
mnuBlack.Checked = False
mnuRed.Checked = True
mnuGreen.Checked = False
mnuBlue.Checked = False
mnuWhite.Checked = False
End Sub
Private Sub lblBlack_Click()
Call GoColour(0) 'QBColor(0) is black
End Sub
Private Sub lblBlue_Click()
Call GoColour(9) 'QBColor(9) is light blue
End Sub
Private Sub lblGreen_Click()
Call GoColour(10) 'QBColor(10) is light green
End Sub
Private Sub lblRed_Click()
Call GoColour(12)
End Sub
Private Sub lblWhite_Click()
Call GoColour(15) 'QBColor(15) is white
End Sub
Private Sub mnuBlack_Click()
Call GoColour(0) 'QBColor(0) is black
End Sub
Private Sub mnuBlue_Click()
Call GoColour(9) 'QBColor(9) is light blue
End Sub
Private Sub mnuClearDraw_Click()
Picture1.Cls
End Sub
Private Sub mnuExit_Click()
End
End Sub
Private Sub mnuGreen_Click()
Call GoColour(10) 'QBColor(10) is light green
End Sub
Private Sub mnuRed_Click()
Call GoColour(12)
End Sub
Private Sub mnuWhite_Click()
Call GoColour(15) 'QBColor(15) is white
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.CurrentX = X
Picture1.CurrentY = Y 'the next line will start here
If Button = 2 Then
Picture1.Circle (X, Y), 200, QBColor(drawcol)
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Picture1.Line -(X, Y), QBColor(drawcol)
End If
End Sub
Private Sub GoColour(new_colour)
drawcol = new_colour
mnuBlack.Checked = (drawcol = 0)
mnuBlue.Checked = (drawcol = 9)
mnuGreen.Checked = (drawcol = 10)
mnuRed.Checked = (drawcol = 12)
mnuWhite.Checked = (drawcol = 15)
End SubThursday, April 19, 2007 10:06 AM -
Code 5 : A funny way to make your control escape from the mouse pointer'In this example you have to put a Command Button on your form and copy this code
'you have to put controls that have top and left properties.
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'here you have to specify the speed of the control.
s = 10
'Here you specify the name of the control you want to go away
With Command1
If Y < .Top Then
.Top = .Top + s
End If
If Y > .Top Then
.Top = .Top - s
End If
If X < .Left Then
.Left = .Left + s
End If
If X > .Left Then
.Left = .Left - s
End If
End With
End SubThursday, April 19, 2007 10:08 AM -
Code 6 : Just a fun thing to doPrivate Sub Command1_Click()
Randomize
MyValue = Int((6 * Rnd) + 1)
If MyValue = 1 Then
Lblanswer = "Not today"
ElseIf MyValue = 2 Then
Lblanswer = "Definitely"
ElseIf MyValue = 3 Then
Lblanswer = "Not today"
ElseIf MyValue = 4 Then
Lblanswer = "Yes"
ElseIf MyValue = 5 Then
Lblanswer = "No"
ElseIf MyValue = 6 Then
Lblanswer = "My sources say maybe"
End If
MyValue = Lblanswer
End SubThursday, April 19, 2007 10:11 AM -
Code 7 : This bounces an object in a form. Can be used for many games'Global Variables
dim DeltaX, DeltaY as Integer
Private Sub timer1_Timer()
img1.move img1.Left + DeltaY, img1.Top + DeltaX
If img1.Left < ScaleLeft Then DeltaY = 100
If img1.Left + img1.Width > ScaleWidth + ScaleLeft Then
DeltaY = -100
End If
If img1.Top < ScaleTop Then DeltaX = 100
If img1.Top + img1.Height > ScaleHeight + ScaleTop Then
DeltaX = -100
End If
'Make Sure Timer1.Enabled = True
Private Sub cmd1_Click()
Timer1.Interval = 50
DeltaX = 100
DeltaY = 100Thursday, April 19, 2007 10:12 AM -
Code 8 : Simple Tic-Tac-Toe Game.
Private Sub cmdNew_Click()
NEWGAME
End Sub
Private Sub lblXY_Click(Index As Integer)
Static HIT As Integer
Dim Rhit As Integer
If InStr(lblRes.Caption, "WINS") > 0 Then Exit Sub
If lblXY(Index).Caption <> "" Then Exit Sub
If HIT = 0 Then
lblXY(Index).Caption = UCase("X")
HIT = 1
Else
lblXY(Index).Caption = UCase("O")
HIT = 0
End If
If lblXY(Index).Caption = UCase("X") Then
lblXY(Index).ForeColor = &HFF&
Else
lblXY(Index).ForeColor = &HFF0000
End If
CHECKX
CHECKY
End Sub
Public Sub CHECKX()
Dim XY As Integer
Dim COMB As Integer
'FOR X WIN
If lblXY(0).Caption = UCase("X") And lblXY(1).Caption = UCase("X") And lblXY(2).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(3).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(5).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(6).Caption = UCase("X") And lblXY(7).Caption = UCase("X") And lblXY(8).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(0).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(8).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(2).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(6).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(1).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(7).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(0).Caption = UCase("X") And lblXY(3).Caption = UCase("X") And lblXY(6).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(1).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(7).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(2).Caption = UCase("X") And lblXY(5).Caption = UCase("X") And lblXY(8).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
End If
End Sub
Public Sub NEWGAME()
Dim XY As Integer
For XY = 0 To 8
lblXY(XY).Caption = ""
Next
lblRes.Caption = ""
End Sub
Public Sub CHECKY()
'FOR Y WIN
If lblXY(0).Caption = UCase("O") And lblXY(1).Caption = UCase("O") And lblXY(2).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(3).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(5).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(6).Caption = UCase("O") And lblXY(7).Caption = UCase("O") And lblXY(8).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(0).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(8).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(2).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(6).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(1).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(7).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(0).Caption = UCase("O") And lblXY(3).Caption = UCase("O") And lblXY(6).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(1).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(7).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(2).Caption = UCase("O") And lblXY(5).Caption = UCase("O") And lblXY(8).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
End If
End SubThursday, April 19, 2007 10:16 AM -
Code 9 : Various registry routines
DeclarationsGlobal Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259
Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_VOLATILE = 0
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
Code 9 : Various registry routines
Code
Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)
' Description:
' This Function will Delete a key
'
' Syntax:
' DeleteKey Location, KeyName
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is name of the key you wish to delete, it may include subkeys (example "Key1\SubKey1")
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
'open the specified key
'lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)
'RegCloseKey (hKey)
End Function
Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
' This Function will delete a value
'
' Syntax:
' DeleteValue Location, KeyName, ValueName
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is the name of the key that the value you wish to delete is in
' , it may include subkeys (example "Key1\SubKey1")
'
' ValueName is the name of value you wish to delete
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
'open the specified key
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = RegDeleteValue(hKey, sValueName)
RegCloseKey (hKey)
End Function
Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
End Select
End Function
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
' Description:
' This Function will create a new key
'
' Syntax:
' QueryValue Location, KeyName
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is name of the key you wish to create, it may include subkeys (example "Key1\SubKey1")
Dim hNewKey As Long 'handle to the new key
Dim lRetVal As Long 'result of the RegCreateKeyEx function
lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
RegCloseKey (hNewKey)
End Function
Sub Main()
'Examples of each function:
'CreateNewKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'SetKeyValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test", "Testing, Testing", REG_SZ
'MsgBox QueryValue(HKEY_CURRENT_USER, "TestKey\SubKey1", "Test")
'DeleteKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'DeleteValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test"
End Sub
Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
' Description:
' This Function will set the data field of a value
'
' Syntax:
' QueryValue Location, KeyName, ValueName, ValueSetting, ValueType
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is the key that the value is under (example: "Key1\SubKey1")
'
' ValueName is the name of the value you want create, or set the value of (example: "ValueTest")
'
' ValueSetting is what you want the value to equal
'
' ValueType must equal either REG_SZ (a string) Or REG_DWORD (an integer)
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
'open the specified key
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)
End Function
Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
' This Function will return the data field of a value
'
' Syntax:
' Variable = QueryValue(Location, KeyName, ValueName)
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is the key that the value is under (example: "Software\Microsoft\Windows\CurrentVersion\Explorer")
'
' ValueName is the name of the value you want to access (example: "link")
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
'MsgBox vValue
QueryValue = vValue
RegCloseKey (hKey)
End FunctionThursday, April 19, 2007 10:36 AM -
Code 10 : Create file association
DeclarationsOption Explicit
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private 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
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Code 10 : Create file association
CodePublic Sub CreateAssociation(sExtension As String, sAppName As String, sFilePath As String)
Dim sPath As String
'File Associations begin with a listing
'of the default extension under HKEY_CLASSES_ROOT.
'So the first step is to create that
'root extension item
CreateNewKey "." & sExtension, HKEY_CLASSES_ROOT
'To the extension just added, add a
'subitem where the registry will look for
'commands relating to the .xxx extension
'("MyApp.Document"). Its type is String (REG_SZ)
SetKeyValue "." & sExtension, "", sAppName & ".Document", REG_SZ
'Create the 'MyApp.Document' item under
'HKEY_CLASSES_ROOT. This is where you'll put
'the command line to execute or other shell
'statements necessary.
CreateNewKey sAppName & ".Document\shell\open\command", HKEY_CLASSES_ROOT
'Set its default item to "MyApp Document".
'This is what is displayed in Explorer against
'for files with a xxx extension. Its type is
'String (REG_SZ)
SetKeyValue sAppName & ".Document", "", sAppName & " Document", REG_SZ
'Finally, add the path to myapp.exe
'Remember to add %1 as the final command
'parameter to assure the app opens the passed
'command line item.
'(results in '"c:\LongPathname\Myapp.exe %1")
'Again, its type is string.
sPath = sFilePath & " %1"
SetKeyValue sAppName & ".Document\shell\open\command", "", sPath, REG_SZ
End Sub
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim nValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
nValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, nValue, 4)
End Select
End Function
Private Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
'handle to the new key
Dim hKey As Long
'result of the RegCreateKeyEx function
Dim r As Long
r = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, r)
Call RegCloseKey(hKey)
End Sub
Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
'result of the SetValueEx function
Dim r As Long
'handle of opened key
Dim hKey As Long
'open the specified key
r = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, KEY_ALL_ACCESS, hKey)
r = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
Call RegCloseKey(hKey)
End SubThursday, April 19, 2007 10:40 AM -
Man you are doing very much good work here. I dont think anyone else is interested in helping others other than you and few people out here
This post has helped me a lot m8. Good work, keep it going. Vusy with exams atmdont get much time to post stuffs.
Thursday, April 19, 2007 12:01 PM -
Hey Harshil, join me as soon as possible. It might be possible that others get interested later. Can't do alone in this thread.Thursday, April 19, 2007 4:49 PM
-
Code 11 : wrapper around the INIFile functionsOption Explicit
Private m_sPath As String
Private m_sKey As String
Private m_sSection As String
Private m_sDefault As String
Private m_lLastReturnCode As Long
#If Win32 Then
' Profile String functions:
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 GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
#End If
Property Get LastReturnCode() As Long
LastReturnCode = m_lLastReturnCode
End Property
Property Get Success() As Boolean
Success = (m_lLastReturnCode <> 0)
End Property
Property Let Default(sDefault As String)
m_sDefault = sDefault
End Property
Property Get Default() As String
Default = m_sDefault
End Property
Property Let Path(sPath As String)
m_sPath = sPath
End Property
Property Get Path() As String
Path = m_sPath
End Property
Property Let Key(sKey As String)
m_sKey = sKey
End Property
Property Get Key() As String
Key = m_sKey
End Property
Property Let Section(sSection As String)
m_sSection = sSection
End Property
Property Get Section() As String
Section = m_sSection
End Property
Property Get Value() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(255)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, m_sKey, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Value = Left$(sBuf, iRetCode)
Else
Value = ""
End If
End Property
Property Let Value(sValue As String)
Dim iPos As Integer
' Strip chr$(0):
iPos = InStr(sValue, Chr$(0))
Do While iPos <> 0
sValue = Left$(sValue, (iPos - 1)) & Mid$(sValue, (iPos + 1))
iPos = InStr(sValue, Chr$(0))
Loop
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, sValue, m_sPath)
End Property
Public Sub DeleteKey()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, 0&, m_sPath)
End Sub
Public Sub DeleteSection()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, 0&, m_sPath)
End Sub
Property Get INISection() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
INISection = Left$(sBuf, iRetCode)
Else
INISection = ""
End If
End Property
Property Let INISection(sSection As String)
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, sSection, m_sPath)
End Property
Property Get Sections() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(0&, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Sections = Left$(sBuf, iRetCode)
Else
Sections = ""
End If
End Property
Public Sub EnumerateCurrentSection(ByRef sKey() As String, ByRef iCount As Long)
Dim sSection As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sKey
sSection = INISection
If (Len(sSection) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sSection, Chr$(0))
Do While iNextPos <> 0
sCur = Mid$(sSection, iPos, (iNextPos - iPos))
If (sCur <> Chr$(0)) Then
iCount = iCount + 1
ReDim Preserve sKey(1 To iCount) As String
sKey(iCount) = Mid$(sSection, iPos, (iNextPos - iPos))
iPos = iNextPos + 1
iNextPos = InStr(iPos, sSection, Chr$(0))
End If
Loop
End If
End Sub
Public Sub EnumerateAllSections(ByRef sSections() As String, ByRef iCount As Long)
Dim sIniFile As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sSections
sIniFile = Sections
If (Len(sIniFile) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Do While iNextPos <> 0
If (iNextPos <> iPos) Then
sCur = Mid$(sIniFile, iPos, (iNextPos - iPos))
iCount = iCount + 1
ReDim Preserve sSections(1 To iCount) As String
sSections(iCount) = sCur
End If
iPos = iNextPos + 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Loop
End If
End Sub
Public Sub SaveFormPosition(ByRef frmThis As Object)
Dim sSaveKey As String
Dim sSaveDefault As String
On Error GoTo SaveError
sSaveKey = Key
If Not (frmThis.WindowState = vbMinimized) Then
Key = "Maximised"
Value = (frmThis.WindowState = vbMaximized) * -1
If (frmThis.WindowState <> vbMaximized) Then
Key = "Left"
Value = frmThis.Left
Key = "Top"
Value = frmThis.Top
Key = "Width"
Value = frmThis.Width
Key = "Height"
Value = frmThis.Height
End If
End If
Key = sSaveKey
Exit Sub
SaveError:
Key = sSaveKey
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Sub LoadFormPosition(ByRef frmThis As Object, Optional ByRef lMinWidth = 3000, Optional ByRef lMinHeight = 3000)
Dim sSaveKey As String
Dim sSaveDefault As String
Dim lLeft As Long
Dim lTOp As Long
Dim lWidth As Long
Dim lHeight As Long
On Error GoTo LoadError
sSaveKey = Key
sSaveDefault = Default
Default = "FAIL"
Key = "Left"
lLeft = CLngDefault(Value, frmThis.Left)
Key = "Top"
lTOp = CLngDefault(Value, frmThis.Top)
Key = "Width"
lWidth = CLngDefault(Value, frmThis.Width)
If (lWidth < lMinWidth) Then lWidth = lMinWidth
Key = "Height"
lHeight = CLngDefault(Value, frmThis.Height)
If (lHeight < lMinHeight) Then lHeight = lMinHeight
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lLeft = Screen.Width - 4 * Screen.TwipsPerPixelX - lWidth
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lWidth = Screen.Width - lLeft - 4 * Screen.TwipsPerPixelX
End If
End If
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lTOp = Screen.Height - 4 * Screen.TwipsPerPixelY - lHeight
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lHeight = Screen.Height - lTOp - 4 * Screen.TwipsPerPixelY
End If
End If
If (lWidth >= lMinWidth) And (lHeight >= lMinHeight) Then
frmThis.Move lLeft, lTOp, lWidth, lHeight
End If
Key = "Maximised"
If (CLngDefault(Value, 0) <> 0) Then
frmThis.WindowState = vbMaximized
End If
Key = sSaveKey
Default = sSaveDefault
Exit Sub
LoadError:
Key = sSaveKey
Default = sSaveDefault
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Function CLngDefault(ByVal sString As String, Optional ByVal lDefault As Long = 0) As Long
Dim lR As Long
On Error Resume Next
lR = CLng(sString)
If (Err.Number <> 0) Then
CLngDefault = lDefault
Else
CLngDefault = lR
End If
End FunctionThursday, April 19, 2007 4:55 PM -
Code 12 : Use TAPI32 to dial a telephone number
DeclarationsPrivate Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" (ByVal DestAddress$, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)
Private Const TAPIERR_NOREQUESTRECIPIENT = -2&
Private Const TAPIERR_REQUESTQUEUEFULL = -3&
Private Const TAPIERR_INVALDESTADDRESS = -4&
Code 12 : Use TAPI32 to dial a telephone number
CodePublic Sub DialNumber(strNumber As String, strLocation As String)
Dim strBuff As String
Dim lngResult As Long
lngResult = tapiRequestMakeCall&(strNumber, CStr(Caption), strLocation, "")
If lngResult <> 0 Then
strBuff = "Error dialing number : "
Select Case lngResult
Case TAPIERR_NOREQUESTRECIPIENT
strBuff = strBuff & "No Windows Telephony dialing application is running and none could be started."
Case TAPIERR_REQUESTQUEUEFULL
strBuff = strBuff & "The queue of pending Windows Telephony dialing requests is full."
Case TAPIERR_INVALDESTADDRESS
strBuff = strBuff & "The phone number is not valid."
Case Else
strBuff = strBuff & "Unknown error."
End Select
MsgBox strBuff
End If
End SubThursday, April 19, 2007 4:58 PM -
Code 13 : Three Ways to Open ADO Connection & Recordset Objects
' There are three ways to open a Connection Object within ADO:
' 1) By Setting the ConnectionString property to a valid Connect string and then calling the Open() method. This connection string is provider- dependent.
' 2) By passing a valid Connect string to the first argument of the Open() method.
' 3) By passing the ODBC Data source name and optionally user-id and password to the Connection Object's Open() method.
' There are three ways to open a Recordset Object within ADO:
' 1) By opening the Recordset off the Connection.Execute() method.
' 2) By opening the Recordset off the Command.Execute() method.
' 3) By opening the Recordset object without a Connection or Command object, and passing an valid Connect string to the second argument of the Recordset.Open() method.
' This code assumes that Nwind.mdb is installed with Visual Basic, and is located in the C:\Program Files\DevStudio\VB directory.
' For more information see Microsoft Knowledgebase Article ID: Q168336
Private Sub cmdOpen_Click()
Dim Conn1 As New adodb.Connection
Dim Cmd1 As New adodb.Command
Dim Errs1 As Errors
Dim Rs1 As New adodb.Recordset
Dim i As Integer
Dim AccessConnect As String
' Error Handling Variables
Dim errLoop As Error
Dim strTmp As String
AccessConnect = "Driver={Microsoft Access Driver (*.mdb)};" & _
"Dbq=nwind.mdb;" & _
"DefaultDir=C:\program files\devstudio\vb;" & _
"Uid=Admin;Pwd=;"
'---------------------------
' Connection Object Methods
'---------------------------
On Error GoTo AdoError ' Full Error Handling which traverses
' Connection object
' Connection Open method #1: Open via ConnectionString Property
Conn1.ConnectionString = AccessConnect
Conn1.Open
Conn1.Close
Conn1.ConnectionString = ""
' Connection Open method #2: Open("[ODBC Connect String]","","")
Conn1.Open AccessConnect
Conn1.Close
' Connection Open method #3: Open("DSN","Uid","Pwd")
Conn1.Open "Driver={Microsoft Access Driver (*.mdb)};" & _
"DBQ=nwind.mdb;" & _
"DefaultDir=C:\program files\devstudio\vb;" & _
"Uid=Admin;Pwd=;"
Conn1.Close
'--------------------------
' Recordset Object Methods
'--------------------------
' Don't assume that we have a connection object.
On Error GoTo AdoErrorLite
' Recordset Open Method #1: Open via Connection.Execute(...)
Conn1.Open AccessConnect
Set Rs1 = Conn1.Execute("SELECT * FROM Employees")
Rs1.Close
Conn1.Close
' Recordset Open Method #2: Open via Command.Execute(...)
Conn1.ConnectionString = AccessConnect
Conn1.Open
Cmd1.ActiveConnection = Conn1
Cmd1.CommandText = "SELECT * FROM Employees"
Set Rs1 = Cmd1.Execute
Rs1.Close
Conn1.Close
Conn1.ConnectionString = ""
' Recordset Open Method #3: Open w/o Connection & w/Connect String
Rs1.Open "SELECT * FROM Employees", AccessConnect, adOpenForwardOnly
Rs1.Close
Done:
Set Rs1 = Nothing
Set Cmd1 = Nothing
Set Conn1 = Nothing
Exit Sub
AdoError:
i = 1
On Error Resume Next
' Enumerate Errors collection and display properties of
' each Error object (if Errors Collection is filled out)
Set Errs1 = Conn1.Errors
For Each errLoop In Errs1
With errLoop
strTmp = strTmp & vbCrLf & "ADO Error # " & i & ":"
strTmp = strTmp & vbCrLf & " ADO Error # " & .Number
strTmp = strTmp & vbCrLf & " Description " & .Description
strTmp = strTmp & vbCrLf & " Source " & .Source
i = i + 1
End With
Next
AdoErrorLite:
' Get VB Error Object's information
strTmp = strTmp & vbCrLf & "VB Error # " & Str(Err.Number)
strTmp = strTmp & vbCrLf & " Generated by " & Err.Source
strTmp = strTmp & vbCrLf & " Description " & Err.Description
MsgBox strTmp
' Clean up gracefully without risking infinite loop in error handler
On Error GoTo 0
GoTo Done
End SubThursday, April 19, 2007 5:03 PM -
Code 14 : function to format field strings that contain apostrophes for processing by an SQL server
Function FormatSQL(StrFieldVal As String) As String
' Format Apostrophes For SQL Statement
Dim ChrPos As Long, PosFound As Long
Dim WrkStr As String
For ChrPos = 1 To Len(StrFieldVal)
PosFound = InStr(ChrPos, StrFieldVal, "'")
If PosFound > 0 Then
WrkStr = WrkStr & Mid(StrFieldVal, ChrPos, PosFound - ChrPos + 1) & "'"
ChrPos = PosFound
Else
WrkStr = WrkStr & Mid(StrFieldVal, ChrPos, Len(StrFieldVal))
ChrPos = Len(StrFieldVal)
End If
Next ChrPos
FormatSQL = WrkStr
End FunctionThursday, April 19, 2007 5:06 PM -
Code 15 : Export sql data to a CSV FilePublic Function CSVExport(db As DAO.Database, sSQL As String, sDest As String) As Boolean
Dim record As Recordset
Dim nI As Long
Dim nJ As Long
Dim nFile As Integer
Dim sTmp As String
On Error GoTo Err_Handler
Set record = db.OpenRecordset(sSQL, DAO.dbOpenDynaset, DAO.dbReadOnly)
' *** Open output file
nFile = FreeFile
Open sDest For Output As #nFile
' *** Export fields name
For nI = 0 To record.Fields.Count - 1
sTmp = "" & (record.Fields(nI).Name)
Write #nFile, sTmp;
Next
Write #nFile,
If record.RecordCount > 0 Then
record.MoveLast
record.MoveFirst
For nI = 1 To record.RecordCount
For nJ = 0 To record.Fields.Count - 1
sTmp = "" & (record.Fields(nJ))
Write #nFile, sTmp;
Next
Write #nFile,
record.MoveNext
Next
End If
Close #nFile
CSVExport = True
Exit Function
Err_Handler:
MsgBox ("Error: " & Err.Description)
CSVExport = False
End FunctionThursday, April 19, 2007 5:10 PM -
I hope its not a problem, if i post some queries also here
in one of yoru codes i saw
On Error GoTo 0 <---- uptil now i have seen On error goto LABeL, but what does this 0 mean ? if you could explain, it would be really nice.Friday, April 20, 2007 1:01 PM -
Hi Harshil,
Here goes answer for your query.
In VB, you can number lines. The numbering of lines starts from 1, and cannot be changed. When you write error handler statement as "On Error GoTo 0", it means that goto some undefined memory location, where no code is written for handling error, i.e., error is simply ignored.
I think that you must have got answer for your query.
Waiting for your reply,Sunday, April 22, 2007 4:16 PM -
Hey Deepak,
Here goes answer for your query.
To change mouse pointer in VB, you can use 2 methods.
1. Load pointer from one of the system defined pointers.
2. Load some cursor icon to use as a pointer.
For the 1st, the code should be :Screen.Mousepointer = 11
Here’s a list of the available Mouse Pointer properties.
Property Property Index Description
0 Default
1 Arrow
2 Cross Hairs
3 I Beam
4 Icon
5 Size
6 Size NESW
7 Size NS
8 Size NW
9 Size EW
10 Up Arrow
11 Hourglass
12 No Drop
13 Arrow and hourglass
14 Arrow and question mark
15 Size all.
99 Custom icon
For the 2nd method, the code looks like :
Object.MouseIcon = LoadPicture("PathandFileName”)Sunday, April 22, 2007 4:29 PM -
Thanks @Sanket, i have got my answer
you are too good in explaining things
thanks m8, and keep it going.
Sunday, April 22, 2007 4:39 PM -
@ Harshil,
Thanks for that good question, and really its my pleasure that I was able to answer your query..
Please post some codes here also from your side. I'm waiting for that.
@ Others
You are free to put your sample codes and ask queries here in this thread. We'll try to discuss your queries.Monday, April 23, 2007 1:22 PM -
Yes m8, i will try and find out some good sample codes, but after my exam finishes
dont get much time for anything else, still i am trying hard to take up time for this forum
Monday, April 23, 2007 2:18 PM -
And i guess the admins should appreciate us and give points to us , cause we spend lot of our precious time even during the exams for helping othersMonday, April 23, 2007 2:19 PM
-
Code 16 : Populate a combo box from a database backend without using an ADODC Control
Declarations:Dim rs as ADODB.Recordset
Dim Con as ADODB.Connection
Dim ssql as String
Const strCon =_ "DSN=Contacts;Description=Contacts;SERVER=ServerName;UID=sa;Password=;"
Code 16 : Populate a combo box from a database backend without using an ADODC Control
Code:Private Sub combo1_DropDown()
Set Con = New ADODB.Connection
Set rs = New ADODB.Recordset
Con.Open strCon
'sql statement to select items on the drop down list
ssql = "Select LastName From Contacts"
rs.Open ssql, Con
Do Until rs.EOF
combo1.AddItem rs("LastName") 'Adds lastnames to dropdown list
rs.MoveNext
Loop
'Close connection and the recordset
rs.Close
Set rs = Nothing
Con.Close
Set Con = Nothing
End SubMonday, April 23, 2007 6:02 PM -
Code 17 : Search all records with have the same category to other tablesPrivate Sub Command1_click()
Dim search as variant
sstr = InputBox("Enter Author to Search") ' Display a Input Box Window
data1.recordset.findfirst "Author='" & sstr & "'" ' Look for the record that has a value "sstr"
If trim(sstr) <> "" then
If data1.recordset.nomatch then 'check if the record exist
MsgBox "No record Exist"
Command1.setfocus
else
data1.recordsource = "SELECT * FROM TableName WHERE Author='" & sstr & "'" ' Display all the Records that has a Value of "sstr"
data1.refresh ' refresh the DBGRID or MSFLEXGRID
End if
End if
End SubMonday, April 23, 2007 6:06 PM -
Code 18 : SQL Statement, Select all Distinct Record on a Table and populate it on ComboBox or ListBoxPrivate Sub Form_Load()
Data1.Recordsource = "SELECT DISTINCT <Field> FROM <TableName>" 'Filter Fields with a unique Name
Data1.Refresh ' Refresh The Table
While Not Data1.Recordset.EOF
Combo1.AddItem Data1.Recordset("Field") 'Field on SELECT
Data1.Recordset.MoveNext ' View all Field Content
Wend
End Sub
'Note U can use (ListBox or ComboBox)
'U can also code it on CLICK Event and KEYPRESS EventMonday, April 23, 2007 6:08 PM -
Code 19 : Retreive ALL the information about Access Table & Fields using ADO
Declarations:Option Explicit
'Properties of the Catalog
Private Catalog As ADOX.Catalog
Private Col As ADOX.Column
Private Cols As ADOX.Columns
Private Grp As ADOX.Group
Private Grps As ADOX.Groups
Private Ndx As ADOX.Index
Private Ndxs As ADOX.Indexes
Private Key As ADOX.Key
Private Keys As ADOX.Keys
Private Proc As ADOX.Procedure
Private Procs As ADOX.Procedures
Private Prop As ADOX.Property
Private Props As ADOX.Properties
Private Table As ADOX.Table
Private Tables As ADOX.Tables
Private User As ADOX.User
Private Users As ADOX.Users
Private View As ADOX.View
Private Views As ADOX.Views
Public Enum TblProps
tblTempTable = 0
tblValidationText = 1
tblValidationRule = 2
tblCacheLinkNamePassword = 3
tblRemoteTableName = 4
tblLinkProviderString = 5
tblLinkDataSource = 6
tblExclusiveLink = 7
tblCreateLink = 8
tblTableHiddenInAccess = 9
End Enum
Public Enum ColProps
colAutoincrement = 0
colDefault = 1
colDescription = 2
colNullable = 3
colFixedLength = 4
colSeed = 5
colIncrement = 6
colValidationText = 7
colValidationRule = 8
colIISNotLastColumn = 9
colAutoGenerate = 10
colOneBlobPerPage = 11
colCompressedUnicode = 12
colAllowZeroLength = 13
colHyperlink = 14
End Enum
Code 19 : Retreive ALL the information about Access Table & Fields using ADOPublic Function ColumnFormat(TableName As String, Column As Variant) As Variant
Code:
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler
Set Table = Tables(TableName)
Set Cols = Table.Columns
Set Col = Cols(Column)
ColumnFormat = NumberFormat(Col.Type)
ExitHere:
Set Table = Nothing
Set Cols = Nothing
Set Col = Nothing
Exit Function
ErrHandler:
ColumnFormat = ""
Resume ExitHere
End Function
Public Function ColumnProperty(TableName As String, Column As Variant, Property As ColProps) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler
Set Table = Tables(TableName)
Set Cols = Table.Columns
Set Col = Cols(Column)
ColumnProperty = Col.Properties(Property).Value
ExitHere:
Set Table = Nothing
Set Cols = Nothing
Set Col = Nothing
Exit Function
ErrHandler:
ColumnProperty = ""
Resume ExitHere
End Function
Public Function TableProperty(TableName As String, Property As TblProps) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler
Set Table = Tables(TableName)
Set Props = Table.Properties
TableProperty = Table.Properties(Property).Value
ExitHere:
Set Table = Nothing
Set Props = Nothing
Exit Function
ErrHandler:
TableProperty = Nothing
Resume ExitHere
End Function
Private Function NumberFormat(ColType As ADODB.DataTypeEnum) As String
Select Case ColType
Case adEmpty ' 0 - No value was specified (DBTYPE_EMPTY).
Case adSmallInt: NumberFormat = "General Number" ' 2 - A 2-byte signed integer (DBTYPE_I2).
Case adInteger: NumberFormat = "General Number" ' 3 - A 4-byte signed integer (DBTYPE_I4).
Case adSingle: NumberFormat = "General Number" ' 4 - A single-precision floating point value (DBTYPE_R4).
Case adDouble: NumberFormat = "General Number" ' 5 - A double-precision floating point value (DBTYPE_R8).
Case adCurrency: NumberFormat = "Currency" ' 6 - A currency value (DBTYPE_CY). Currency is a fixed-point number with four digits to the right of the decimal point. It is stored in an 8-byte signed integer scaled by 10,000.
Case adDate: NumberFormat = "General Date" ' 7 - A Date value (DBTYPE_DATE). A date is stored as a Double, the whole part of which is the number of days since December 30, 1899, and the fractional part of which is the fraction of a day.
Case adBSTR ' 8 - A null-terminated character string (Unicode) (DBTYPE_BSTR).
Case adIDispatch ' 9 - A pointer to an IDispatch interface on an OLE object (DBTYPE_IDISPATCH).
Case adError ' 10 - A 32-bit error code (DBTYPE_ERROR).
Case adBoolean: NumberFormat = "True/False" ' 11 - A Boolean value (DBTYPE_BOOL).
Case adVariant ' 12 - An Automation Variant (DBTYPE_VARIANT).
Case adIUnknown ' 13 - A pointer to an IUnknown interface on an OLE object (DBTYPE_IUNKNOWN).
Case adDecimal: NumberFormat = "Standard" ' 14 - An exact numeric value with a fixed precision and scale (DBTYPE_DECIMAL).
Case adTinyInt: NumberFormat = "General Number" ' 16 - A 1-byte signed integer (DBTYPE_I1).
Case adUnsignedTinyInt: NumberFormat = "General Number" ' 17 - A 1-byte unsigned integer (DBTYPE_UI1).
Case adUnsignedSmallInt: NumberFormat = "General Number" ' 18 - A 2-byte unsigned integer (DBTYPE_UI2).
Case adUnsignedInt: NumberFormat = "General Number" ' 19 - A 4-byte unsigned integer (DBTYPE_UI4).
Case adUnsignedBigInt: NumberFormat = "General Number" ' 21 - An 8-byte unsigned integer (DBTYPE_UI8).
Case adBigInt: NumberFormat = "General Number" ' 20 - An 8-byte signed integer (DBTYPE_I8).
Case adGUID ' 72 - A globally unique identifier (GUID) (DBTYPE_GUID).
Case adBinary '128 - A binary value (DBTYPE_BYTES).
Case adChar '129 - A String value (DBTYPE_STR).
Case adWChar '130 - A null-terminated Unicode character string (DBTYPE_WSTR).
Case adNumeric: NumberFormat = "General Number" '131 - An exact numeric value with a fixed precision and scale (DBTYPE_NUMERIC).
Case adUserDefined '132 - A user-defined variable (DBTYPE_UDT).
Case adDBDate: NumberFormat = "General Date" '133 - A date value (yyyymmdd) (DBTYPE_DBDATE).
Case adDBTime: NumberFormat = "Long Time" '134 - A time value (hhmmss) (DBTYPE_DBTIME).
Case adDBTimeStamp: NumberFormat = "General Date" '135 - A date-time stamp (yyyymmddhhmmss plus a fraction in billionths) (DBTYPE_DBTIMESTAMP).
Case adVarChar '200 - A String value (Parameter object only).
Case adLongVarChar '201 - A long String value (Parameter object only).
Case adVarWChar '202 - A null-terminated Unicode character string (Parameter object only).
Case adLongVarWChar '203 - A long null-terminated string value (Parameter object only).
Case adVarBinary '204 - A binary value (Parameter object only).
Case adLongVarBinary '205 - A long binary value (Parameter object only).
End Select
End Function
Private Function SetCatalog() As ADOX.Catalog
'Retrieves the description of the field
'Cat.Tables(1).Columns(1).Properties(2).Value
'Set DBCatalog = Cat
'Set Cat = Nothing
If Not Catalog Is Nothing Then
End If
End Function
Private Sub Class_Initialize()
'Create the Catlog
Set Catalog = New ADOX.Catalog
Catalog.ActiveConnection = cnADO
Set Tables = Catalog.Tables
Set Users = Catalog.Users
Set Views = Catalog.Views
Set Procs = Catalog.Procedures
Set Grps = Catalog.Groups
End Sub
Private Sub Class_Terminate()
Set Col = Nothing
Set Cols = Nothing
Set Grp = Nothing
Set Grps = Nothing
Set Ndx = Nothing
Set Ndxs = Nothing
Set Key = Nothing
Set Keys = Nothing
Set Proc = Nothing
Set Procs = Nothing
Set Prop = Nothing
Set Props = Nothing
Set Table = Nothing
Set Tables = Nothing
Set User = Nothing
Set Users = Nothing
Set View = Nothing
Set Views = Nothing
Set Catalog = Nothing
End SubMonday, April 23, 2007 6:24 PM -
Code 20 : Create a MS Access database using 4 lines of code'set a reference to the Microsoft DAO 3.5 Object library then use the code below
Dim ws As Workspace
Dim db As Database
Set ws = DBEngine.Workspaces(0)
'substitute Password with the desired password
Set db = ws.CreateDatabase("test.mdb", dbLangGeneral & ";pwd=Password")Monday, April 23, 2007 6:26 PM -
Code 21 : Use Format/UnFormat events of Format Object in VB6Option Explicit
'Binds TextBox controls to the ADO control.
Dim bc As New BindingCollection
'
'We'll add code to Format/UnFormat events on this object.
Dim WithEvents fProduct As StdDataFormat
Dim msOrigProductName As String 'For saved data.
Private Sub Form_Load()
'Connect the BindingCollection object to the datasource.
Set bc.DataSource = Adodc1
Set fProduct = New StdDataFormat
bc.Add txtProduct, "Text", "ProductName", fProduct, "product"
End Sub
Private Sub fProduct_Format(ByVal DataValue As StdFormat.StdDataValue)
'
Debug.Print "Formated ProductName: " & DataValue.Value
'
'Save the original value of ProductName.
msOrigProductName = DataValue.Value
'
'Change it to upper case and then sent to data-bound control.
DataValue.Value = UCase(DataValue.Value)
'
End Sub
Private Sub fProduct_UnFormat(ByVal DataValue As StdFormat.StdDataValue)
'
'Always write the saved data back to DB so that no data was changed.
DataValue.Value = msOrigProductName
'
End SubMonday, April 23, 2007 6:29 PM -
Code 22 : writes the contents of an ADO RecordSet to a ascii text file with user specified column & row delimiters
Option Explicit
Private iFileNumber As Integer
Private sFilePath As String
Private sDelimeter As String
Private sRowDelimeter As String
Private lErrorNumber As Long
Private sErrorDescription As String
Private sErrorPlace As String
Public Property Get GetErrorNumber() As Long
GetErrorNumber = lErrorNumber
End Property
Public Property Get GetErrorDescription() As String
GetErrorDescription = sErrorDescription
End Property
Public Property Get GetErrorPlace() As String
GetErrorPlace = sErrorPlace
End Property
Public Property Let FilePath(ByVal inFilePath As String)
sFilePath = inFilePath
End Property
Public Property Get GetFilePath() As String
GetFilePath = sFilePath
End Property
Public Property Let Delimeter(ByVal inDelimeter As String)
sDelimeter = inDelimeter
End Property
Public Property Get GetDelimeter() As String
GetDelimeter = sDelimeter
End Property
Public Property Let RowDelimeter(ByVal inRowDelimeter As String)
sRowDelimeter = inRowDelimeter
End Property
Public Property Get GetRowDelimeter() As String
GetRowDelimeter = sRowDelimeter
End Property
Public Function Write2File(Optional ByRef inRecordSet As ADODB.Recordset, _
Optional ByRef inFilePath As String, _
Optional ByRef inDelimeter As String, _
Optional ByRef inRowDelimeter As String, _
Optional ByRef inAppend As Boolean, _
Optional ByRef inHeaderRecord As String) As Long
On Error GoTo ErrorHandler
'Default: Delimeter is ","
' RowDelimeter is VBCrLF
Dim sTempRecord As String
Dim dRecords As Double
Dim dIndex As Double
Dim iCol As Integer
Dim iMaxCols As Integer
'Check if anything to do
If (IsEmpty(inRecordSet)) Then
Exit Function
Else
If (inRecordSet.RecordCount = 0) Then
Exit Function
Else
dRecords = inRecordSet.RecordCount
End If
End If
'File Path
If (Len(inFilePath) > 0) Then
sFilePath = inFilePath
Else
If (Len(sFilePath) < 1) Then
Exit Function
End If
End If
'Set up the Column Delimeter
If (Len(inDelimeter) > 0) Then
sDelimeter = inDelimeter
Else
If (Len(sDelimeter) < 1) Then
sDelimeter = ","
End If
End If
'Set up the Row Delimeter
If (Len(inRowDelimeter) > 0) Then
sRowDelimeter = inRowDelimeter
Else
If (Len(sRowDelimeter) < 1) Then
sRowDelimeter = vbCrLf
End If
End If
Call OpenFile(inAppend)
If (Len(inHeaderRecord) > 0) Then
Print #iFileNumber, inHeaderRecord
End If
iMaxCols = inRecordSet.Fields.Count - 1
inRecordSet.MoveFirst
'This if statement is to accomodate a bug in .movenext
'where the record set only contains one record...
If (dRecords = 1) Then
sTempRecord = inRecordSet.Fields(0).Value
For iCol = 1 To iMaxCols
sTempRecord = sTempRecord & sDelimeter & inRecordSet.Fields(iCol).Value
Next iCol
Print #iFileNumber, sTempRecord
Else
While dIndex < dRecords
sTempRecord = inRecordSet.Fields(0).Value
For iCol = 1 To iMaxCols
sTempRecord = sTempRecord & sDelimeter & inRecordSet.Fields(iCol).Value
Next iCol
Print #iFileNumber, sTempRecord
dIndex = dIndex + 1
inRecordSet.MoveNext
Wend
End If
CloseFile
DoEvents
Exit Function
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "OpenInterfaceFile()"
End Function
Private Sub OpenFile(ByRef inAppend As Boolean)
On Error GoTo ErrorHandler
iFileNumber = FreeFile
If (inAppend) Then
'Check if Error file already exists
If (Dir(sFilePath) = "") Then
Open sFilePath For Output As #iFileNumber
Else
Open sFilePath For Append As #iFileNumber
End If
Else
Open sFilePath For Output As #iFileNumber
End If
Exit Sub
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "OpenLogFile()"
End Sub
Private Sub CloseFile()
On Error GoTo ErrorHandler
Close #iFileNumber
Exit Sub
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseInterfaceFile()"
End SubMonday, April 23, 2007 6:31 PM -
Code 23 : Simplifies ADO 2.x access
Option Explicit
Private Const ConstCommandTimeout = 60
Private Const ConstDatabaseTimeout = 60
Private oDBConnection As New ADODB.Connection
Private oADOCommand As New ADODB.Command
Private oDbRecordSet As New ADODB.Recordset
Attribute oDbRecordSet.VB_VarHelpID = -1
Private iADODatabaseTimeout As Integer
Private iADOCommandTimeout As Integer
Private iCacheSize As Integer
Private lResult As Long
Private sDSN As String
Private sUserName As String
Private sPassword As String
Private sDatabase As String
Private lErrorNumber As Long
Private sErrorDescription As String
Private sErrorPlace As String
Private sODBCString As String
Private sProviderString As String
Private bLogFile As Boolean
Private sLogFilePath As String
Private iLogFileNumber As Integer
Private sSQLString As String
Private bProviderConnection As Boolean
Private bLogging As Boolean
Public Property Let LogFilePath(ByVal vData As String)
sLogFilePath = vData
End Property
Public Property Get LogFilePath() As String
LogFilePath = sLogFilePath
End Property
Public Property Let Logging(ByVal vData As Boolean)
bLogging = vData
End Property
Public Property Get Logging() As Boolean
Logging = bLogging
End Property
Public Property Get Connection() As ADODB.Connection
Set Connection = oDBConnection
End Property
Public Sub Class_Initialize()
On Error GoTo errhandler
Call Initialize
Exit Sub
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Class_Initialize()"
End Sub
Private Sub Initialize()
bLogging = False
iADOCommandTimeout = ConstCommandTimeout
iADODatabaseTimeout = ConstDatabaseTimeout
sDSN = ""
sUserName = ""
sPassword = ""
sDatabase = ""
sODBCString = ""
sSQLString = ""
lErrorNumber = 0
sErrorDescription = ""
sErrorPlace = ""
sODBCString = ""
sProviderString = ""
sSQLString = ""
sLogFilePath = ""
End Sub
Public Sub Class_Terminate()
Call Initialize
If (oDBConnection.State = 1) Then
Me.CloseConnection
End If
End Sub
Public Property Get VersionInfo() As String
VersionInfo = App.Path + "\" + App.EXEName + "." + TypeName(Me) + _
" " + CStr(App.Major) + _
" . " + CStr(App.Minor) + " . " + CStr(App.Revision)
End Property
Public Property Get GetErrorNumber() As Long
GetErrorNumber = lErrorNumber
End Property
Public Property Get GetErrorDescription() As String
GetErrorDescription = sErrorDescription
End Property
Public Property Get GetErrorPlace() As String
GetErrorPlace = sErrorPlace
End Property
Public Property Let DSN(ByVal inDSN As String)
sDSN = inDSN
End Property
Public Property Get DSN() As String
DSN = sDSN
End Property
Public Property Get RecordCount() As Integer
RecordCount = oDbRecordSet.RecordCount
End Property
Public Property Let CacheSize(ByVal inCacheSize As Integer)
iCacheSize = inCacheSize
End Property
Public Property Get CacheSize() As Integer
CacheSize = iCacheSize
End Property
Public Property Let MaxRecords(ByVal inMaxRecords As Double)
On Error GoTo errhandler
If (inMaxRecords > 0) Then
oDbRecordSet.MaxRecords = inMaxRecords
End If
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let MaxRecords()"
End Property
Public Property Get MaxRecords() As Double
On Error GoTo errhandler
MaxRecords = oDbRecordSet.MaxRecords
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get MaxRecords()"
End Property
Public Property Let ProviderConnection(ByVal inValue As Boolean)
On Error GoTo errhandler
bProviderConnection = inValue
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ProviderConnection()"
End Property
Public Property Get ProviderConnection() As Boolean
On Error GoTo errhandler
ProviderConnection = bProviderConnection
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ProviderConnection()"
End Property
Public Property Let ADODatabaseTimeout(ByVal inADODatabaseTimeout As Integer)
On Error GoTo errhandler
iADODatabaseTimeout = inADODatabaseTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ADODatabaseTimeout()"
End Property
Public Property Get ADODatabaseTimeout() As Integer
On Error GoTo errhandler
ADODatabaseTimeout = iADODatabaseTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ADODatabaseTimeout()"
End Property
Public Property Let ADOCommandTimeout(ByVal inADOCommandTimeout As Integer)
On Error GoTo errhandler
iADOCommandTimeout = inADOCommandTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ADOCommandTimeout()"
End Property
Public Property Get ADOCommandTimeout() As Integer
On Error GoTo errhandler
ADOCommandTimeout = iADOCommandTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ADOCommandTimeout()"
End Property
Public Property Let UserName(ByVal inUserName As String)
On Error GoTo errhandler
sUserName = inUserName
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let UserName()"
End Property
Public Property Get UserName() As String
On Error GoTo errhandler
UserName = sUserName
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get UserName()"
End Property
Public Property Let Password(ByVal inPassword As String)
On Error GoTo errhandler
sPassword = inPassword
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let Password()"
End Property
Public Property Get Password() As String
On Error GoTo errhandler
Password = sPassword
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get Password()"
End Property
Public Property Let Database(ByVal inDatabase As String)
On Error GoTo errhandler
sDatabase = inDatabase
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let Database()"
End Property
Public Property Get Database() As String
On Error GoTo errhandler
Database = sDatabase
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get Database()"
End Property
Public Property Let Provider(ByVal inProviderString As String)
On Error GoTo errhandler
sProviderString = inProviderString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let Provider()"
End Property
Public Property Get Provider() As String
On Error GoTo errhandler
Provider = sProviderString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get Provider()"
End Property
Public Property Let ODBCString(ByVal inODBCString As String)
On Error GoTo errhandler
sODBCString = inODBCString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ODBCString()"
End Property
Public Property Get ODBCString() As String
On Error GoTo errhandler
ODBCString = sODBCString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ODBCString()"
End Property
Public Property Let SQLString(ByVal inSQLString As String)
On Error GoTo errhandler
sSQLString = inSQLString
oADOCommand.CommandText = sSQLString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let SQLString()"
End Property
Public Property Get SQLString() As String
On Error GoTo errhandler
SQLString = sSQLString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get SQLString()"
End Property
Public Property Let ADOCommandText(ByVal inText As String)
On Error GoTo errhandler
oADOCommand.CommandText = inText
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ADOCommandText()"
End Property
Public Property Get ADOCommandText() As String
On Error GoTo errhandler
ADOCommandText = oADOCommand.CommandText
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ADOCommandText()"
End Property
Public Function SetODBCString(Optional ByVal inDSN As String, Optional ByVal inUserName As String, Optional ByVal inPassword As String, Optional ByVal inDatabase As String) As Boolean
On Error GoTo errhandler
Dim TheDSN As String
Dim TheUserName As String
Dim ThePassword As String
Dim TheDatabase As String
SetODBCString = False
If (inDSN = "") Then
If (sDSN = "") Then
Exit Function
Else
TheDSN = sDSN
End If
Else
TheDSN = inDSN
End If
If (inUserName = "") Then
If (sUserName = "") Then
Exit Function
Else
TheUserName = sUserName
End If
Else
TheUserName = inUserName
End If
If (inPassword = "") Then
If (sPassword = "") Then
Exit Function
Else
ThePassword = sPassword
End If
Else
ThePassword = inPassword
End If
If (inDatabase = "") Then
If (sDatabase = "") Then
Exit Function
Else
TheDatabase = sDatabase
End If
Else
TheDatabase = inDatabase
End If
sODBCString = "DSN=" & TheDSN & ";uid=" & TheUserName & ";pwd=" & ThePassword & ";database=" & TheDatabase
SetODBCString = True
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Set SetODBCString()"
SetODBCString = False
End Function
Public Function GetState() As Integer
On Error GoTo errhandler
GetState = oDBConnection.State
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get State()"
GetState = lErrorNumber
End Function
Public Function OpenODBCConnection() As Long
On Error GoTo errhandler
If (ODBCString = "") Then
OpenODBCConnection = -2
Else
oDBConnection.Open sODBCString
If (oDBConnection.State = 1) Then
Set oADOCommand.ActiveConnection = oDBConnection
oDbRecordSet.CursorLocation = adUseClient
OpenODBCConnection = 0 'OK
Else
OpenODBCConnection = -1 'Error
End If
End If
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CRVADOAccess.OpenODBCConnection()"
OpenODBCConnection = lErrorNumber
End Function
Public Function OpenProviderConnection() As Long
On Error GoTo errhandler
If (sProviderString = "") Then
OpenProviderConnection = -2
Else
oDBConnection.Open sProviderString
If (oDBConnection.State = 1) Then
oDbRecordSet.CursorLocation = adUseClient
Set oADOCommand.ActiveConnection = oDBConnection
OpenProviderConnection = 0 'OK
Else
OpenProviderConnection = -1 'Error
End If
End If
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CRVADOAccess.OpenProviderConnection()"
OpenProviderConnection = lErrorNumber
End Function
Public Function SubmitQuery(Optional ByRef inSQLString As String, _
Optional ByRef inCursor As String) As Long
On Error GoTo errhandler
Dim sCursor As String
If (Len(inCursor) > 0) Then
sCursor = inCursor
Else
sCursor = adOpenForwardOnly
End If
'Check if Connected
If (oDBConnection.State = 0) Then 'Not Connected
If (ProviderConnection) Then
lResult = OpenProviderConnection
Else
lResult = OpenODBCConnection
End If
If (lResult <> 0) Then
Exit Function
End If
End If
'Check if Record Set Open
If (oDbRecordSet.State <> 0) Then 'RecordSet is open
oDbRecordSet.Close
End If
'Check if SQL in method call
If (inSQLString = "") Then
If (bLogging) Then
WriteLogRecord oADOCommand.CommandText
End If
oDbRecordSet.Open oADOCommand, oDBConnection, sCursor
Else
If (bLogging) Then
WriteLogRecord inSQLString
End If
oADOCommand.CommandText = inSQLString
oDbRecordSet.Open oADOCommand
'Debug.Print oDbRecordSet.RecordCount
End If
SubmitQuery = 0 'Return OK
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "SubmitQuery()"
If (bLogging) Then
WriteLogRecord lErrorNumber & " " & sErrorDescription
End If
SubmitQuery = lErrorNumber 'Return Error
End Function
Public Function ADOCommandExecute() As Integer
On Error GoTo errhandler
oADOCommand.Execute
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "ADOCommandExecute()"
End Function
Public Function RetrieveRecordSet() As ADODB.Recordset
On Error GoTo errhandler
'This function returns a clone of the recordset
Set RetrieveRecordSet = oDbRecordSet.Clone
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "RetrieveRecordSet()"
Set RetrieveRecordSet = Nothing
End Function
Public Function RetrieveRecordSetPointer() As ADODB.Recordset
On Error GoTo errhandler
'This function returns a pointer to the recordset
Set RetrieveRecordSetPointer = oDbRecordSet
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "RetrieveRecordSetPointer()"
Set RetrieveRecordSetPointer = Nothing
End Function
Public Function CloseRecordSet() As Long
On Error GoTo errhandler
If (oDbRecordSet.State = 1) Then
oDbRecordSet.Close
End If
CloseRecordSet = oDbRecordSet.State
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseConnection()"
End Function
Public Function CloseConnection() As Long
On Error GoTo errhandler
If (oDBConnection.State = 1) Then
oDBConnection.Close
CloseConnection = 0
Else
CloseConnection = -1
End If
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseConnection()"
End Function
Public Function MoveFirst() As Boolean
On Error GoTo errhandler
oDbRecordSet.MoveFirst
MoveFirst = True
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "MoveFirst()"
MoveFirst = False
End Function
Private Sub WriteLogRecord(inSQL As String)
On Error Resume Next
iLogFileNumber = FreeFile
'Check if file already exists
If (Dir(sLogFilePath) = "") Then
Open sLogFilePath For Output As #iLogFileNumber
Else
Open sLogFilePath For Append As #iLogFileNumber
End If
'Write out the record
Print #iLogFileNumber, inSQL
Close #iLogFileNumber
End SubMonday, April 23, 2007 6:34 PM -
Code 24 : code for saving into a file what is in listboxSub Savelist(list as listbox, name as string)
for i = 0 to list.listcount -1
data$ = list.list(i)
open name for output as #1
print #1, data$
close 1
next i
End SubMonday, April 23, 2007 6:36 PM -
Code 25 : Save ADO Recordset data in XML format filePrivate Sub Command1_Click()
'
'Modified from Microsoft KB sample.
'You need to have ADO 2.1 installed on your machine and set reference to it first.
'
Dim Rst1 As New ADODB.Recordset
Dim Rst2 As New ADODB.Recordset
'
Rst1.Fields.Append "xx1", adInteger
Rst1.Fields.Append "xx2", adChar, 5
Rst1.Fields.Refresh
'
'Add something to it. Have to open it first.
Rst1.Open
Rst1.AddNew
Rst1.Fields(0).Value = 1
Rst1.Fields(1).Value = "NAME1"
Rst1.Update
'
Kill "C:\Recordset.XML"
'
'Persist data in Recordset to an XML file
Rst1.Save "c:\Recordset.xml", adPersistXML
Rst1.Close
Set Rst1 = Nothing
'
'Read XML file data into Recordset.
Rst2.Open "c:\Recordset.xml"
Do Until Rst2.EOF
Debug.Print Rst2(0), Rst2(1)
Rst2.MoveNext
Loop
'
Rst2.Close
Set Rst2 = Nothing
'
'If you have IE5 on your machine, you can use it to open this xml file.
'
End SubMonday, April 23, 2007 6:39 PM -
Code 26 : A easy way to get data from MSAccess parameter query into ADO RecordsetPrivate Sub Command1_Click()
'
'Set reference to ADO library first.
'In my test, the parameter query will return all records in table PRODUCTS
'whoes ProductID <= the passed value. It looks like this:
'SELECT Products.* FROM Products WHERE (Products.ProductID<=IDMax);
'
Dim Cnn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
'
'Open a Connection using an ODBC DSN.
Cnn.Open "DSN=adoobj;UID=;PWD=;"
'
'All records whose ProductID <= 3 will be returned.
Set Rst = Cnn.Execute("qry_storedproc 3", , adCmdStoredProc)
'
Do While Not Rst.EOF
Debug.Print Rst(0)
Rst.MoveNext
Loop
'
Set Rstc = Nothing
Set Cnn = Nothing
'
End SubMonday, April 23, 2007 6:41 PM -
Code 27 : pass parameters to stored procedures of Oracle when using Command.Execute method in ADO'From MSDN online help sample, if you want to pass parameters to a stored
'procedure, you need to create parameter objects, append them to ADO Command
'object, and then assign the values. But I found an easy way to do the same
'work if you are going to call procedures in Oracle. In the same method, you can
'return from an Oracle PL/SQl function.
'
Dim strSQL As String
Dim qryStoredProc As New ADODB.Command
Dim id As Long
Dim name As String
'
With qryStoredProc
.CommandText = "scott.instrec"
.CommandType = adCmdStoredProc
.ActiveConnection = mCnn 'Suppose that you already have a valid one.
End With
'
id = CLng(InputBox("Enter an integer below:"))
name = InputBox("Enter the name:")
'
'Insert a new record into Oracle table.
qryStoredProc(0) = id
qryStoredProc(1) = name
qryStoredProc.Execute
'
'The first parameter is InOut and the other is Out.
MsgBox "ParamInOut: " & qryStoredProc(0) & _
NL & "ParamOut: " & qryStoredProc(2)
'----------------------------------------------------------
'The Oracle table MYTEST has only two cols: MYID and MYTEST
'The code for the stored procedure is listed below.
'
'procedure instrec (
' p_id in out number, p_name in varchar2,
' p_id_plus out number
' ) AS
'BEGIN
' insert into mytest values(p_id, p_name);
' commit;
' -- Testing only
' p_id_plus:=p_id+1;
' p_id:=p_id+1;
'END instrec;
Monday, April 23, 2007 6:43 PM -
Code 28 : A speedy way to find how many rows are in a large table
'Suppose you already set refernece to ADO library, and objCnn is a opened
'Connection object, using ODBC driver.
'
'Benefits:
'1. If the table is very large, this way will be very fast. In my test,
'a MSAccess table has almost 180K records. Once I have a active Connection
'object, it took about one second to get the count of records. If I use
'ADODB.Recordset to open the table and then use Recordset.RecordCount property
'to do the same job, it took more than 50 seconds.
'2. In case the Recordset dose not support adApproxPosition or adBookmark, like
'my case using ODBC driver for Oracle, you can use this.
'Anyone has better way to do this, please let me know. I'll appreciate your
'generosity.
'
'I think it will work for VBScripts or ASP too.
'
Public Function plGetRecCount(objCnn As ADODB.Connection, sTBL As String) As Long
'
Dim Rst As New ADODB.Recordset
Dim lRecCount As Long
Dim sSQL As String
'
On Error GoTo Err_Handler
'
sSQL = "SELECT Count(*) As RecNum From " & sTBL
'
Set Rst = objCnn.Execute(sSQL)
'
lRecCount = Rst.Fields("RecNum")
plGetRecCount = lRecCount
'
Rst.Close
Set Rst = Nothing
'
Exit Function
'
Err_Handler:
'
plGetRecCount = -1
MsgBox objCnn.Errors(0).Description
'
End FunctionMonday, April 23, 2007 6:47 PM -
Code 29 : Using ADO, transfering the content(records) of one table to another.Private Sub Command1_Click()
Dim icounter As Integer
Dim dtart As Double, dfinish As Double
Dim pnlstatus As Panel
Static i As Integer
Set pnlstatus = Form1.StatusBar1.Panels(1)
dstart = Timer
Adodc1.Refresh
Adodc2.Refresh
On Error Resume Next
ProgressBar1.Visible = True
pnlstatus.Text = "Transfering data please wait...."
StatusBar1.Refresh
ProgressBar1.Max = Val(Text1.Text)
For icounter = 1 To Val(Text1.Text)
If icounter Mod 10 = 0 Then ProgressBar1.Value = icounter
Next icounter
pnlstatus.Text = "Transfer Complete...."
StatusBar1.Refresh
'transfer the record to new table
For i = 0 To Adodc1.Recordset.RecordCount
Adodc2.Recordset.AddNew
Adodc2.Recordset("EmpNum") = Adodc1.Recordset("Empnum")
Adodc2.Recordset("EmpName") = Adodc1.Recordset("EmpName")
Adodc1.Recordset.MoveNext
Next i
Adodc1.Refresh
Adodc2.Refresh
'delete the record after transfering
For i = 0 To Adodc1.Recordset.RecordCount
Adodc1.Recordset.Delete
Adodc1.Recordset.MoveNext
Next i
'end of deletion
dfinish = Timer
pnlstatus.Text = "Ready..."
ProgressBar1.Value = 0
ProgressBar1.Visible = False
Command2.Enabled = True
Command1.Enabled = False
End Sub
Private Sub Command2_Click()
Dim icounter As Integer
Dim dtart As Double, dfinish As Double
Dim pnlstatus As Panel
Static i As Integer
Set pnlstatus = Form1.StatusBar1.Panels(1)
dstart = Timer
Adodc1.Refresh
Adodc2.Refresh
On Error Resume Next
ProgressBar1.Visible = True
pnlstatus.Text = "Returning data please wait...."
StatusBar1.Refresh
ProgressBar1.Max = Val(Text1.Text)
For icounter = 1 To Val(Text1.Text)
If icounter Mod 10 = 0 Then ProgressBar1.Value = icounter
Next icounter
pnlstatus.Text = "Return Complete...."
StatusBar1.Refresh
'transfer the record to new table
For i = 0 To Adodc2.Recordset.RecordCount
Adodc1.Recordset.AddNew
Adodc1.Recordset("EmpNum") = Adodc2.Recordset("Empnum")
Adodc1.Recordset("EmpName") = Adodc2.Recordset("EmpName")
Adodc2.Recordset.MoveNext
Next i
Form1.Adodc1.Refresh
Form1.Adodc2.Refresh
'delete the record after transfering
For i = 0 To Adodc2.Recordset.RecordCount
Adodc2.Recordset.Delete
Adodc2.Recordset.MoveNext
Next i
'end of deletion
dfinish = Timer
pnlstatus.Text = "Ready..."
ProgressBar1.Value = 0
ProgressBar1.Visible = False
Command2.Enabled = False
Command1.Enabled = True
End Sub
Private Sub Command3_Click()
End
End SubMonday, April 23, 2007 6:50 PM -
Code 30 : Using ADO to open an Access MDB DSN-lessDim CN1 as New ADODB.Connection
Dim RS1 as New ADODB.Recordset
Dim sSQL as String
CN1.CursorLocation = adUseClient
CN1.Provider = "Microsoft.Jet.OLEDB.4.0"
CN1.Open App.Path & "\MyDatabase.MDB", "", ""
sSql = "Select * From Address Order By [LName]"
RS1.Open sSql, CN1, adOpenDynamic, adLockOptimistic, adCmdTextMonday, April 23, 2007 6:52 PM -
Code 31 : Saving ADO Recordset to a text file with user-defined requirements such as col/row delimiters'Just make use of the ADODB.Recordset.GetString method. You can modify this
'function by setting some of those parameters to Optional to make it more
'flexible and meet your own need. I am just lazy.
Public Sub SaveRecInText(RstPrm As ADODB.Recordset, _
FileSpec As String, RowCount As Long, _
ColDeli As String, RowDeli As String, _
NullRep As String)
'
Dim sBuffer As String
Dim FileNum As Long
'
sBuffer = RstPrm.GetString(adClipString, RowCount, ColDeli, RowDeli, NullRep)
'
'Remove the file first if it exists.
If Len(Dir(FileSpec)) > 0 Then
Kill FileSpec
End If
'
FileNum = FreeFile
Open FileSpec For Binary As FileNum
Put FileNum, , sBuffer
Close FileNum
'
End SubMonday, April 23, 2007 6:55 PM -
Code 32 : Stores any binary data into the Database field. ex: zip files, exe files, images etc
'------------ Put this into a module ---------------------
Function CopyFieldToFile(rst As DAO.Recordset, fd As String, strFileName As String) As String
Dim FileNum As Integer
Dim Buffer() As Byte
Dim BytesNeeded As Long
Dim Buffers As Long
Dim Remainder As Long
Dim Offset As Long
Dim r As Integer
Dim i As Long
Dim ChunkSize As Long
ChunkSize = 65536
BytesNeeded = rst(fd).FieldSize
If BytesNeeded > 0 Then
' Calculate the number of buffers needed to copy
Buffers = BytesNeeded \ ChunkSize
Remainder = BytesNeeded Mod ChunkSize
' Get a unique, temporary filename:
If Dir(strFileName) <> "" Then
Kill strFileName
End If
' Copy the bitmap to the temporary file chunk by chunk:
FileNum = FreeFile
Open strFileName For Binary As #FileNum
For i = 0 To Buffers - 1
ReDim Buffer(ChunkSize)
Buffer = rst(fd).GetChunk(Offset, ChunkSize)
Put #FileNum, , Buffer()
Offset = Offset + ChunkSize
Next ' Copy the remaining chunk of the bitmap to the file:
ReDim Buffer(Remainder)
Buffer = rst(fd).GetChunk(Offset, Remainder)
Put #FileNum, , Buffer()
Close #FileNum
End If
CopyFieldToFile = strFileName
End Function
Function CopyFileToField(FileName As String, fd As DAO.Field)
Dim ChunkSize As Long
Dim FileNum As Integer
Dim Buffer() As Byte
Dim BytesNeeded As Long
Dim Buffers As Long
Dim Remainder As Long
Dim i As Long
If Len(FileName) = 0 Then
Exit Function
End If
If Dir(FileName) = "" Then
Err.Raise vbObjectError, , "File not found: """ & FileName & """"
End If
ChunkSize = 65536
FileNum = FreeFile
Open FileName For Binary As #FileNum
BytesNeeded = LOF(FileNum)
Buffers = BytesNeeded \ ChunkSize
Remainder = BytesNeeded Mod ChunkSize
For i = 0 To Buffers - 1
ReDim Buffer(ChunkSize)
Get #FileNum, , Buffer
fd.AppendChunk Buffer
Next
ReDim Buffer(Remainder)
Get #FileNum, , Buffer
fd.AppendChunk Buffer
Close #FileNum
End Function
'----------- Use of CopyFieldToFile ----------------
1. You must have a recordset open.
Call CopyFieldToFile <recordset>, "<Field>", "<Filename>"
'----------- Use of CopyFileToField ----------------
1. You must have a recordset open.
Call CopyFileToField "<Filename>", "<FieldToWriteTheFileTo>"Monday, April 23, 2007 6:59 PM -
very awesome work m8, i really liked the cod number 32
One doubt, what does KILL do ? Never came across such a statement in vb
and btw, i am learning lot of new things that i didn't even knew, after you started this thread.Tuesday, April 24, 2007 12:56 PM -
Kill statement is used to delete a file.
But its very dangerous as it will not have any undo facility. It means that once you have deleted any file / files using it, its not possible to recover the deleted file.Tuesday, April 24, 2007 6:57 PM -
Code 33 : List Database names of by Driver type and server name using ADOPublic Sub GetDatabases(strDriver As String, strServer As String, cboToFill As ComboBox)
Dim cn As New ADODB.Connection
Dim rsSchema As New ADODB.Recordset
Dim ConnStr As String
ConnStr = "driver={" & strDriver & "};"
ConnStr = ConnStr & "server=" & strServer & ";"
ConnStr = ConnStr & "uid=sa;pwd=;"
cn.ConnectionString = ConnStr
cn.Open
Set rsSchema = cn.OpenSchema(adSchemaCatalogs)
Do Until rsSchema.EOF
cboToFill.AddItem rsSchema!Catalog_Name
rsSchema.MoveNext
Loop
End SubTuesday, April 24, 2007 7:13 PM -
Code 34 : Retrieving Access 97 password.
DeclarationsDim n As Long, s1 As String * 1, s2 As String * 1
Dim lsClave As String
Dim mask As String
Code 34 : Retrieving Access 97 password.
Codemask = Chr(78) & Chr(134) & Chr(251) & Chr(236) & _
Chr(55) & Chr(93) & Chr(68) & Chr(156) & _
Chr(250) & Chr(198) & Chr(94) & Chr(40) & Chr(230) & Chr(19)
Open "c:\protected db.mdb" For Binary As #1
Seek #1, &H42
For n = 1 To 14
s1 = Mid(mask, n, 1)
s2 = Input(1, 1)
If (Asc(s1) Xor Asc(s2)) <> 0 Then
lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2))
End If
Next
Close 1
MsgBox "The Password Is: " & lsClaveTuesday, April 24, 2007 7:17 PM -
Code 35 : whenever Database has been modified check if it was and refreshes contents
DeclarationsPublic rst as ADODB.Recordset
Public db as ADODB.Connection
Code 35 : whenever Database has been modified check if it was and refreshes contents
Code''I used this Code to for Updating the TreeView after change has
been made in
''the database.
Private Sub cmdConnect_Click()
Set db = New ADODB.Connection
Set rst = New ADODB.Recordset
db.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=d:\hfs200.mdb"
rst.Open "SELECT tblManifest.Container, tblManifest.Seal,
tblManifest.Origin FROM tblManifest;", db, adOpenDynamic, adLockOptimistic
varRst = rst.GetRows
rst.MoveFirst
End Sub
Private Sub Timer1_Timer()
Set db = New ADODB.Connection
Set rst = New ADODB.Recordset
db.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=d:\hfs200.mdb"
rst.Open "SELECT tblManifest.Container, tblManifest.Seal,
tblManifest.Origin FROM tblManifest;", db, adOpenDynamic, adLockOptimistic
varRst2 = rst.GetRows
rst.MoveFirst
Call CompareVars ''Here we call Matching Subroutine.
End Sub
Sub CompareVars()
dim x as long
dim y as long
dim cols as long
for x = 0 to UBound(varRst, 2)
for cols = 0 to Ubound(varRst, 1)
if varRst(cols, x) <> varRST2(cols, x) then
''Here i call TreeView Refresh because we found the change.
cmdConnect.Value = True ''Clicks the Button to connect.
end if
next
next
End SubTuesday, April 24, 2007 7:21 PM -
Code 36 : Extract the data from an ADO Recordset into a 2-D variant arrayFunction RecordsetToVarArray(oRst As ADODB.Recordset) As Variant()
Dim avarStuff() As Variant ' Hold the returned records
Dim fldThis As ADODB.Field ' Iterator for the Fields collection
Dim iIndex As Integer ' Loop index
' Resize the array to hold the column names
ReDim avarStuff(1 To oRst.Fields.Count, 0 To 0) As Variant
' Extract all the column names from the Fields collection
iIndex = 1
For Each fldThis In oRst.Fields
avarStuff(iIndex, 0) = fldThis.Name
iIndex = iIndex + 1
Next fldThis
' Move to the first record in the recordset
oRst.MoveFirst
' Loop through the records, and build the 2-D array
Do While Not oRst.EOF
ReDim Preserve avarStuff(LBound(avarStuff, 1) To UBound(avarStuff, 1), _
LBound(avarStuff, 2) To (UBound(avarStuff, 2) + 1)) As Variant
For iIndex = LBound(avarStuff, 1) To UBound(avarStuff, 1)
avarStuff(iIndex, UBound(avarStuff, 2)) = _
oRst.Fields(avarStuff(iIndex, 0)).Value
Next iIndex
oRst.MoveNext
Loop
' Return the array
RecordsetToVarArray = avarStuff()
End FunctionTuesday, April 24, 2007 7:24 PM -
Hi Sanket ur forum is working excellently!!!
well can u explain me how to add the image files in the database(Ms Access)?
which datatype i have put in that field?
and how to load it from vb?
Thursday, April 26, 2007 5:16 PM -
Very awesome m8, i also agree that your thread is SUPERPFriday, April 27, 2007 12:34 PM
-
Jet DB Operations
DeclarationsJust paste it in your .bas/modules
Modules = .Bas File
The object type is a database object dao/ado database
============
For DAO
dim wkData as dao.workspace
Dim dbData as dao.Database
============
For ADo
din cnn as new connection
*Sample
OpenDatabaseWithPassWord(dbData, "Test.mdb", "vbcode")
OpenConnectionWithPassWord(cnn,"Provider=Microsoft.Jet.OLEDB.4.0;","Data Source=" + app.path + "\"+ "Test.mdb","vbcode")
Jet DB Operations
CodeOption Explicit
'* Open the Database Password in DAO
Sub OpendatabaseWithPassword(DB As Object, strDatabase As String, strPass As String)
Set DB = DBEngine.OpenDatabase(App.Path & "\" & strDatabase, False, False, ";pwd=" & strPass)
End Sub
'* Open Database Password in ADO
Sub OpenConnectionWithPassword(DB As Object, strProvider, strDataSource As String, strPassWord As String)
DB.Open _
strProvider & _
strDataSource & _
strPassWord
End Sub
'* Change The Database Password in DAO
Sub ChangeDBPassword_DAO(DB As Object, strDatabase As String, strOldPass As String, strNewPass As String)
Set DB = DBEngine.OpenDatabase(App.Path & "\" & strDatabase, True, False, ";pwd=" & strOldPass)
DB.NewPassword strOldPass, strNewPass
DB.Close
End Sub
'* Change The User-Level Password in DAO
Sub ChangeUserPassword_DAO(DB As Object, strOldPass As String, strNewPass As String)
DBEngine.SystemDB = "c:\win98\system\system.mdw"
Set DB = DBEngine.CreateWorkspace("", "Admin", strOldPass)
DB.Users("Admin").NewPassword strOldPass, strNewPass
DB.Close
End Sub
'* Change The User-Level Password in ADO
'* Assumes that the Admin user doesn't currently have a password set
'* Provider=Microsoft.Jet.OLEDB.4.0;
Sub ChangeUserPassword_ADO(DB As Object, strProvider, strDataSource As String, strSystem As String, strOldPassword As String, strNewPassword As String)
DB.ActiveConnection = _
strProvider & _
strDataSource & _
strSystem
DB.Users("Admin").ChangePassword strOldPassword, strNewPassword
Set DB = Nothing
End Sub
'* Add The New User Group and Password in DAO
Sub CreateUserGroup_DAO(DB As Object, User As Object, NewUser As String, strPID As String, strPassWord As String, wrkPass As String)
DBEngine.SystemDB = "c:\win98\system\system.mdw"
Set DB = DBEngine.CreateWorkspace("", "Admin", wrkPass)
Set User = DB.CreateUser(NewUser, strPID, strPassWord)
DB.Users.Append User
DB.Close
End Sub
'* Add The New User To Group
Sub AddUserToGroup(DB As Object, strPass As String, strNewUser As String, strNewGroup)
DBEngine.SystemDB = "c:\win98\system\system.mdw"
Set DB = DBEngine.CreateWorkspace("", "Admin", strPass)
DB.Users(strNewUser).Groups.Append _
DB.Users(strNewUser).CreateGroup(strNewGroup)
DB.Close
End SubTuesday, May 8, 2007 9:12 AM
All replies
-
Thanks Sanket, i was really wanting to have a VB6.0 thread. as many other forums and even MS have discontinued official support for VB6.0
Wish this post a very good luck. Ill also try to post many codes, but after my exams
Thursday, April 19, 2007 9:54 AM -
Various joy stick functions, determine if a joy stick is presentPublic Const JOY_BUTTON1 = &H1
Public Const JOY_BUTTON2 = &H2
Public Const JOY_BUTTON3 = &H4
Public Const JOY_BUTTON4 = &H8
Public Type JOYINFO
X As Long
Y As Long
Z As Long
Buttons As Long
End Type
' Private defs
Private Const JOYERR_BASE = 160
Private Const JOYERR_NOERROR = (0)
Private Const JOYERR_NOCANDO = (JOYERR_BASE + 6)
Private Const JOYERR_PARMS = (JOYERR_BASE + 5)
Private Const JOYERR_UNPLUGGED = (JOYERR_BASE + 7)
Private Const MAXPNAMELEN = 32
Private Type JOYCAPS
wMid As Integer
wPid As Integer
szPname As String * MAXPNAMELEN
wXmin As Long
wXmax As Long
wYmin As Long
wYmax As Long
wZmin As Long
wZmax As Long
wNumButtons As Long
wPeriodMin As Long
wPeriodMax As Long
End Type
Private Declare Function joyGetDevCaps Lib "winmm.dll" _
Alias "joyGetDevCapsA" (ByVal id As Long, _
lpCaps As JOYCAPS, ByVal uSize As Long) As Long
Private Declare Function joyGetNumDevs Lib "winmm.dll" _
() As Long
Private Declare Function joyGetPos Lib "winmm.dll" _
(ByVal uJoyID As Long, pji As JOYINFO) As Long
CodePublic Function GetJoyMin(ByVal joy As Integer, ji As JOYINFO) As Boolean
Dim jc As JOYCAPS
If joyGetDevCaps(joy, jc, Len(jc)) <> JOYERR_NOERROR Then
GetJoyMin = False
Else
ji.X = jc.wXmin
ji.Y = jc.wYmin
ji.Z = jc.wZmin
ji.Buttons = jc.wNumButtons
GetJoyMin = True
End If
End Function
'
' Fills the ji structure with the maximum x, y, and z
' coordinates. Buttons is filled with the number of
' buttons.
'
Public Function GetJoyMax(ByVal joy As Integer, ji As JOYINFO) As Boolean
Dim jc As JOYCAPS
If joyGetDevCaps(joy, jc, Len(jc)) <> JOYERR_NOERROR Then
GetJoyMax = False
Else
ji.X = jc.wXmax
ji.Y = jc.wYmax
ji.Z = jc.wZmax
ji.Buttons = jc.wNumButtons
GetJoyMax = True
End If
End Function
Public Function GetJoystick(ByVal joy As Integer, ji As JOYINFO) As Boolean
If joyGetPos(joy, ji) <> JOYERR_NOERROR Then
GetJoystick = False
Else
GetJoystick = True
End If
End Function
'
' If IsConnected is False then it returns the number of
' joysticks the driver supports. (But may not be connected)
'
' If IsConnected is True the it returns the number of
' joysticks present and connected.
'
' IsConnected is true by default.
'
Public Function IsJoyPresent(Optional IsConnected As Variant) As Long
Dim ic As Boolean
Dim i As Long
Dim j As Long
Dim ret As Long
Dim ji As JOYINFO
ic = IIf(IsMissing(IsConnected), True, CBool(IsConnected))
i = joyGetNumDevs
If ic Then
j = 0
Do While i > 0
i = i - 1 'Joysticks id's are 0 and 1
If joyGetPos(i, ji) = JOYERR_NOERROR Then
j = j + 1
End If
Loop
IsJoyPresent = j
Else
IsJoyPresent = i
End If
End FunctionThursday, April 19, 2007 9:59 AM -
Thanks Harshil for supporting me, and also Best of Luck for your exams.Thursday, April 19, 2007 10:01 AM
-
Reads strings from an INI file
'Reads strings from INI files
Function readstringINI(ini_file As String, ini_section As String, ini_entry As String, default As String) As String
Dim section As String, entry As String
Dim foundsection As Integer
Dim foundentry As Integer
Open ini_file For Input As #1
'Finding the section...
Do While (Not EOF(1)) And (foundsection = 0)
Line Input #1, section
If Left(section, 1) = "[" Then
foundsection = InStr(section, ini_section)
End If
Loop
'Finding the entry...
If foundsection = 0 Then
'MsgBox "Section not found"
Else
Do
Line Input #1, entry
foundentry = InStr(entry, ini_entry)
Loop While (Not EOF(1)) And (foundsection <> 0) And (foundentry = 0) And (Left(entry, 1) <> "[")
'If foundentry = 0 Then MsgBox "Entry not found"
End If
If (foundsection <> 0) And (foundentry <> 0) Then
Dim position As Integer, length As Integer
position = InStr(entry, "=")
length = Len(entry)
position = length - position
readstringINI = Right(entry, position)
Else
readstringINI = default
End If
Close #1
End FunctionThursday, April 19, 2007 10:02 AM -
Code 3 : Makes a string appear on on the active formPrint "I am cool --Sanket T. Shah."
Thursday, April 19, 2007 10:04 AM -
Code 4 : Makes a drawing application similar to paintPrivate Sub cmdClear_Click()
Picture1.Cls
End Sub
Private Sub Form_Load()
drawcol = 12 'use red to start with
mnuBlack.Checked = False
mnuRed.Checked = True
mnuGreen.Checked = False
mnuBlue.Checked = False
mnuWhite.Checked = False
End Sub
Private Sub lblBlack_Click()
Call GoColour(0) 'QBColor(0) is black
End Sub
Private Sub lblBlue_Click()
Call GoColour(9) 'QBColor(9) is light blue
End Sub
Private Sub lblGreen_Click()
Call GoColour(10) 'QBColor(10) is light green
End Sub
Private Sub lblRed_Click()
Call GoColour(12)
End Sub
Private Sub lblWhite_Click()
Call GoColour(15) 'QBColor(15) is white
End Sub
Private Sub mnuBlack_Click()
Call GoColour(0) 'QBColor(0) is black
End Sub
Private Sub mnuBlue_Click()
Call GoColour(9) 'QBColor(9) is light blue
End Sub
Private Sub mnuClearDraw_Click()
Picture1.Cls
End Sub
Private Sub mnuExit_Click()
End
End Sub
Private Sub mnuGreen_Click()
Call GoColour(10) 'QBColor(10) is light green
End Sub
Private Sub mnuRed_Click()
Call GoColour(12)
End Sub
Private Sub mnuWhite_Click()
Call GoColour(15) 'QBColor(15) is white
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.CurrentX = X
Picture1.CurrentY = Y 'the next line will start here
If Button = 2 Then
Picture1.Circle (X, Y), 200, QBColor(drawcol)
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Picture1.Line -(X, Y), QBColor(drawcol)
End If
End Sub
Private Sub GoColour(new_colour)
drawcol = new_colour
mnuBlack.Checked = (drawcol = 0)
mnuBlue.Checked = (drawcol = 9)
mnuGreen.Checked = (drawcol = 10)
mnuRed.Checked = (drawcol = 12)
mnuWhite.Checked = (drawcol = 15)
End SubThursday, April 19, 2007 10:06 AM -
Code 5 : A funny way to make your control escape from the mouse pointer'In this example you have to put a Command Button on your form and copy this code
'you have to put controls that have top and left properties.
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'here you have to specify the speed of the control.
s = 10
'Here you specify the name of the control you want to go away
With Command1
If Y < .Top Then
.Top = .Top + s
End If
If Y > .Top Then
.Top = .Top - s
End If
If X < .Left Then
.Left = .Left + s
End If
If X > .Left Then
.Left = .Left - s
End If
End With
End SubThursday, April 19, 2007 10:08 AM -
Code 6 : Just a fun thing to doPrivate Sub Command1_Click()
Randomize
MyValue = Int((6 * Rnd) + 1)
If MyValue = 1 Then
Lblanswer = "Not today"
ElseIf MyValue = 2 Then
Lblanswer = "Definitely"
ElseIf MyValue = 3 Then
Lblanswer = "Not today"
ElseIf MyValue = 4 Then
Lblanswer = "Yes"
ElseIf MyValue = 5 Then
Lblanswer = "No"
ElseIf MyValue = 6 Then
Lblanswer = "My sources say maybe"
End If
MyValue = Lblanswer
End SubThursday, April 19, 2007 10:11 AM -
Code 7 : This bounces an object in a form. Can be used for many games'Global Variables
dim DeltaX, DeltaY as Integer
Private Sub timer1_Timer()
img1.move img1.Left + DeltaY, img1.Top + DeltaX
If img1.Left < ScaleLeft Then DeltaY = 100
If img1.Left + img1.Width > ScaleWidth + ScaleLeft Then
DeltaY = -100
End If
If img1.Top < ScaleTop Then DeltaX = 100
If img1.Top + img1.Height > ScaleHeight + ScaleTop Then
DeltaX = -100
End If
'Make Sure Timer1.Enabled = True
Private Sub cmd1_Click()
Timer1.Interval = 50
DeltaX = 100
DeltaY = 100Thursday, April 19, 2007 10:12 AM -
Code 8 : Simple Tic-Tac-Toe Game.
Private Sub cmdNew_Click()
NEWGAME
End Sub
Private Sub lblXY_Click(Index As Integer)
Static HIT As Integer
Dim Rhit As Integer
If InStr(lblRes.Caption, "WINS") > 0 Then Exit Sub
If lblXY(Index).Caption <> "" Then Exit Sub
If HIT = 0 Then
lblXY(Index).Caption = UCase("X")
HIT = 1
Else
lblXY(Index).Caption = UCase("O")
HIT = 0
End If
If lblXY(Index).Caption = UCase("X") Then
lblXY(Index).ForeColor = &HFF&
Else
lblXY(Index).ForeColor = &HFF0000
End If
CHECKX
CHECKY
End Sub
Public Sub CHECKX()
Dim XY As Integer
Dim COMB As Integer
'FOR X WIN
If lblXY(0).Caption = UCase("X") And lblXY(1).Caption = UCase("X") And lblXY(2).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(3).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(5).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(6).Caption = UCase("X") And lblXY(7).Caption = UCase("X") And lblXY(8).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(0).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(8).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(2).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(6).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(1).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(7).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(0).Caption = UCase("X") And lblXY(3).Caption = UCase("X") And lblXY(6).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(1).Caption = UCase("X") And lblXY(4).Caption = UCase("X") And lblXY(7).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
ElseIf lblXY(2).Caption = UCase("X") And lblXY(5).Caption = UCase("X") And lblXY(8).Caption = UCase("X") Then
lblRes.Caption = "X WINS"
End If
End Sub
Public Sub NEWGAME()
Dim XY As Integer
For XY = 0 To 8
lblXY(XY).Caption = ""
Next
lblRes.Caption = ""
End Sub
Public Sub CHECKY()
'FOR Y WIN
If lblXY(0).Caption = UCase("O") And lblXY(1).Caption = UCase("O") And lblXY(2).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(3).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(5).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(6).Caption = UCase("O") And lblXY(7).Caption = UCase("O") And lblXY(8).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(0).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(8).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(2).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(6).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(1).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(7).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(0).Caption = UCase("O") And lblXY(3).Caption = UCase("O") And lblXY(6).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(1).Caption = UCase("O") And lblXY(4).Caption = UCase("O") And lblXY(7).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
ElseIf lblXY(2).Caption = UCase("O") And lblXY(5).Caption = UCase("O") And lblXY(8).Caption = UCase("O") Then
lblRes.Caption = "O WINS"
End If
End SubThursday, April 19, 2007 10:16 AM -
Code 9 : Various registry routines
DeclarationsGlobal Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259
Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_VOLATILE = 0
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
Code 9 : Various registry routines
Code
Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)
' Description:
' This Function will Delete a key
'
' Syntax:
' DeleteKey Location, KeyName
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is name of the key you wish to delete, it may include subkeys (example "Key1\SubKey1")
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
'open the specified key
'lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)
'RegCloseKey (hKey)
End Function
Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
' This Function will delete a value
'
' Syntax:
' DeleteValue Location, KeyName, ValueName
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is the name of the key that the value you wish to delete is in
' , it may include subkeys (example "Key1\SubKey1")
'
' ValueName is the name of value you wish to delete
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
'open the specified key
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = RegDeleteValue(hKey, sValueName)
RegCloseKey (hKey)
End Function
Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
End Select
End Function
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
' Description:
' This Function will create a new key
'
' Syntax:
' QueryValue Location, KeyName
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is name of the key you wish to create, it may include subkeys (example "Key1\SubKey1")
Dim hNewKey As Long 'handle to the new key
Dim lRetVal As Long 'result of the RegCreateKeyEx function
lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
RegCloseKey (hNewKey)
End Function
Sub Main()
'Examples of each function:
'CreateNewKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'SetKeyValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test", "Testing, Testing", REG_SZ
'MsgBox QueryValue(HKEY_CURRENT_USER, "TestKey\SubKey1", "Test")
'DeleteKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'DeleteValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test"
End Sub
Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
' Description:
' This Function will set the data field of a value
'
' Syntax:
' QueryValue Location, KeyName, ValueName, ValueSetting, ValueType
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is the key that the value is under (example: "Key1\SubKey1")
'
' ValueName is the name of the value you want create, or set the value of (example: "ValueTest")
'
' ValueSetting is what you want the value to equal
'
' ValueType must equal either REG_SZ (a string) Or REG_DWORD (an integer)
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
'open the specified key
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)
End Function
Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
' This Function will return the data field of a value
'
' Syntax:
' Variable = QueryValue(Location, KeyName, ValueName)
'
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' , HKEY_USERS
'
' KeyName is the key that the value is under (example: "Software\Microsoft\Windows\CurrentVersion\Explorer")
'
' ValueName is the name of the value you want to access (example: "link")
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
'MsgBox vValue
QueryValue = vValue
RegCloseKey (hKey)
End FunctionThursday, April 19, 2007 10:36 AM -
Code 10 : Create file association
DeclarationsOption Explicit
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private 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
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Code 10 : Create file association
CodePublic Sub CreateAssociation(sExtension As String, sAppName As String, sFilePath As String)
Dim sPath As String
'File Associations begin with a listing
'of the default extension under HKEY_CLASSES_ROOT.
'So the first step is to create that
'root extension item
CreateNewKey "." & sExtension, HKEY_CLASSES_ROOT
'To the extension just added, add a
'subitem where the registry will look for
'commands relating to the .xxx extension
'("MyApp.Document"). Its type is String (REG_SZ)
SetKeyValue "." & sExtension, "", sAppName & ".Document", REG_SZ
'Create the 'MyApp.Document' item under
'HKEY_CLASSES_ROOT. This is where you'll put
'the command line to execute or other shell
'statements necessary.
CreateNewKey sAppName & ".Document\shell\open\command", HKEY_CLASSES_ROOT
'Set its default item to "MyApp Document".
'This is what is displayed in Explorer against
'for files with a xxx extension. Its type is
'String (REG_SZ)
SetKeyValue sAppName & ".Document", "", sAppName & " Document", REG_SZ
'Finally, add the path to myapp.exe
'Remember to add %1 as the final command
'parameter to assure the app opens the passed
'command line item.
'(results in '"c:\LongPathname\Myapp.exe %1")
'Again, its type is string.
sPath = sFilePath & " %1"
SetKeyValue sAppName & ".Document\shell\open\command", "", sPath, REG_SZ
End Sub
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim nValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
nValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, nValue, 4)
End Select
End Function
Private Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
'handle to the new key
Dim hKey As Long
'result of the RegCreateKeyEx function
Dim r As Long
r = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, r)
Call RegCloseKey(hKey)
End Sub
Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
'result of the SetValueEx function
Dim r As Long
'handle of opened key
Dim hKey As Long
'open the specified key
r = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, KEY_ALL_ACCESS, hKey)
r = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
Call RegCloseKey(hKey)
End SubThursday, April 19, 2007 10:40 AM -
Man you are doing very much good work here. I dont think anyone else is interested in helping others other than you and few people out here
This post has helped me a lot m8. Good work, keep it going. Vusy with exams atmdont get much time to post stuffs.
Thursday, April 19, 2007 12:01 PM -
Hey Harshil, join me as soon as possible. It might be possible that others get interested later. Can't do alone in this thread.Thursday, April 19, 2007 4:49 PM
-
Code 11 : wrapper around the INIFile functionsOption Explicit
Private m_sPath As String
Private m_sKey As String
Private m_sSection As String
Private m_sDefault As String
Private m_lLastReturnCode As Long
#If Win32 Then
' Profile String functions:
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 GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
#End If
Property Get LastReturnCode() As Long
LastReturnCode = m_lLastReturnCode
End Property
Property Get Success() As Boolean
Success = (m_lLastReturnCode <> 0)
End Property
Property Let Default(sDefault As String)
m_sDefault = sDefault
End Property
Property Get Default() As String
Default = m_sDefault
End Property
Property Let Path(sPath As String)
m_sPath = sPath
End Property
Property Get Path() As String
Path = m_sPath
End Property
Property Let Key(sKey As String)
m_sKey = sKey
End Property
Property Get Key() As String
Key = m_sKey
End Property
Property Let Section(sSection As String)
m_sSection = sSection
End Property
Property Get Section() As String
Section = m_sSection
End Property
Property Get Value() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(255)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, m_sKey, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Value = Left$(sBuf, iRetCode)
Else
Value = ""
End If
End Property
Property Let Value(sValue As String)
Dim iPos As Integer
' Strip chr$(0):
iPos = InStr(sValue, Chr$(0))
Do While iPos <> 0
sValue = Left$(sValue, (iPos - 1)) & Mid$(sValue, (iPos + 1))
iPos = InStr(sValue, Chr$(0))
Loop
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, sValue, m_sPath)
End Property
Public Sub DeleteKey()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, 0&, m_sPath)
End Sub
Public Sub DeleteSection()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, 0&, m_sPath)
End Sub
Property Get INISection() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
INISection = Left$(sBuf, iRetCode)
Else
INISection = ""
End If
End Property
Property Let INISection(sSection As String)
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, sSection, m_sPath)
End Property
Property Get Sections() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(0&, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Sections = Left$(sBuf, iRetCode)
Else
Sections = ""
End If
End Property
Public Sub EnumerateCurrentSection(ByRef sKey() As String, ByRef iCount As Long)
Dim sSection As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sKey
sSection = INISection
If (Len(sSection) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sSection, Chr$(0))
Do While iNextPos <> 0
sCur = Mid$(sSection, iPos, (iNextPos - iPos))
If (sCur <> Chr$(0)) Then
iCount = iCount + 1
ReDim Preserve sKey(1 To iCount) As String
sKey(iCount) = Mid$(sSection, iPos, (iNextPos - iPos))
iPos = iNextPos + 1
iNextPos = InStr(iPos, sSection, Chr$(0))
End If
Loop
End If
End Sub
Public Sub EnumerateAllSections(ByRef sSections() As String, ByRef iCount As Long)
Dim sIniFile As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sSections
sIniFile = Sections
If (Len(sIniFile) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Do While iNextPos <> 0
If (iNextPos <> iPos) Then
sCur = Mid$(sIniFile, iPos, (iNextPos - iPos))
iCount = iCount + 1
ReDim Preserve sSections(1 To iCount) As String
sSections(iCount) = sCur
End If
iPos = iNextPos + 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Loop
End If
End Sub
Public Sub SaveFormPosition(ByRef frmThis As Object)
Dim sSaveKey As String
Dim sSaveDefault As String
On Error GoTo SaveError
sSaveKey = Key
If Not (frmThis.WindowState = vbMinimized) Then
Key = "Maximised"
Value = (frmThis.WindowState = vbMaximized) * -1
If (frmThis.WindowState <> vbMaximized) Then
Key = "Left"
Value = frmThis.Left
Key = "Top"
Value = frmThis.Top
Key = "Width"
Value = frmThis.Width
Key = "Height"
Value = frmThis.Height
End If
End If
Key = sSaveKey
Exit Sub
SaveError:
Key = sSaveKey
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Sub LoadFormPosition(ByRef frmThis As Object, Optional ByRef lMinWidth = 3000, Optional ByRef lMinHeight = 3000)
Dim sSaveKey As String
Dim sSaveDefault As String
Dim lLeft As Long
Dim lTOp As Long
Dim lWidth As Long
Dim lHeight As Long
On Error GoTo LoadError
sSaveKey = Key
sSaveDefault = Default
Default = "FAIL"
Key = "Left"
lLeft = CLngDefault(Value, frmThis.Left)
Key = "Top"
lTOp = CLngDefault(Value, frmThis.Top)
Key = "Width"
lWidth = CLngDefault(Value, frmThis.Width)
If (lWidth < lMinWidth) Then lWidth = lMinWidth
Key = "Height"
lHeight = CLngDefault(Value, frmThis.Height)
If (lHeight < lMinHeight) Then lHeight = lMinHeight
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lLeft = Screen.Width - 4 * Screen.TwipsPerPixelX - lWidth
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lWidth = Screen.Width - lLeft - 4 * Screen.TwipsPerPixelX
End If
End If
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lTOp = Screen.Height - 4 * Screen.TwipsPerPixelY - lHeight
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lHeight = Screen.Height - lTOp - 4 * Screen.TwipsPerPixelY
End If
End If
If (lWidth >= lMinWidth) And (lHeight >= lMinHeight) Then
frmThis.Move lLeft, lTOp, lWidth, lHeight
End If
Key = "Maximised"
If (CLngDefault(Value, 0) <> 0) Then
frmThis.WindowState = vbMaximized
End If
Key = sSaveKey
Default = sSaveDefault
Exit Sub
LoadError:
Key = sSaveKey
Default = sSaveDefault
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Function CLngDefault(ByVal sString As String, Optional ByVal lDefault As Long = 0) As Long
Dim lR As Long
On Error Resume Next
lR = CLng(sString)
If (Err.Number <> 0) Then
CLngDefault = lDefault
Else
CLngDefault = lR
End If
End FunctionThursday, April 19, 2007 4:55 PM -
Code 12 : Use TAPI32 to dial a telephone number
DeclarationsPrivate Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" (ByVal DestAddress$, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)
Private Const TAPIERR_NOREQUESTRECIPIENT = -2&
Private Const TAPIERR_REQUESTQUEUEFULL = -3&
Private Const TAPIERR_INVALDESTADDRESS = -4&
Code 12 : Use TAPI32 to dial a telephone number
CodePublic Sub DialNumber(strNumber As String, strLocation As String)
Dim strBuff As String
Dim lngResult As Long
lngResult = tapiRequestMakeCall&(strNumber, CStr(Caption), strLocation, "")
If lngResult <> 0 Then
strBuff = "Error dialing number : "
Select Case lngResult
Case TAPIERR_NOREQUESTRECIPIENT
strBuff = strBuff & "No Windows Telephony dialing application is running and none could be started."
Case TAPIERR_REQUESTQUEUEFULL
strBuff = strBuff & "The queue of pending Windows Telephony dialing requests is full."
Case TAPIERR_INVALDESTADDRESS
strBuff = strBuff & "The phone number is not valid."
Case Else
strBuff = strBuff & "Unknown error."
End Select
MsgBox strBuff
End If
End SubThursday, April 19, 2007 4:58 PM -
Code 13 : Three Ways to Open ADO Connection & Recordset Objects
' There are three ways to open a Connection Object within ADO:
' 1) By Setting the ConnectionString property to a valid Connect string and then calling the Open() method. This connection string is provider- dependent.
' 2) By passing a valid Connect string to the first argument of the Open() method.
' 3) By passing the ODBC Data source name and optionally user-id and password to the Connection Object's Open() method.
' There are three ways to open a Recordset Object within ADO:
' 1) By opening the Recordset off the Connection.Execute() method.
' 2) By opening the Recordset off the Command.Execute() method.
' 3) By opening the Recordset object without a Connection or Command object, and passing an valid Connect string to the second argument of the Recordset.Open() method.
' This code assumes that Nwind.mdb is installed with Visual Basic, and is located in the C:\Program Files\DevStudio\VB directory.
' For more information see Microsoft Knowledgebase Article ID: Q168336
Private Sub cmdOpen_Click()
Dim Conn1 As New adodb.Connection
Dim Cmd1 As New adodb.Command
Dim Errs1 As Errors
Dim Rs1 As New adodb.Recordset
Dim i As Integer
Dim AccessConnect As String
' Error Handling Variables
Dim errLoop As Error
Dim strTmp As String
AccessConnect = "Driver={Microsoft Access Driver (*.mdb)};" & _
"Dbq=nwind.mdb;" & _
"DefaultDir=C:\program files\devstudio\vb;" & _
"Uid=Admin;Pwd=;"
'---------------------------
' Connection Object Methods
'---------------------------
On Error GoTo AdoError ' Full Error Handling which traverses
' Connection object
' Connection Open method #1: Open via ConnectionString Property
Conn1.ConnectionString = AccessConnect
Conn1.Open
Conn1.Close
Conn1.ConnectionString = ""
' Connection Open method #2: Open("[ODBC Connect String]","","")
Conn1.Open AccessConnect
Conn1.Close
' Connection Open method #3: Open("DSN","Uid","Pwd")
Conn1.Open "Driver={Microsoft Access Driver (*.mdb)};" & _
"DBQ=nwind.mdb;" & _
"DefaultDir=C:\program files\devstudio\vb;" & _
"Uid=Admin;Pwd=;"
Conn1.Close
'--------------------------
' Recordset Object Methods
'--------------------------
' Don't assume that we have a connection object.
On Error GoTo AdoErrorLite
' Recordset Open Method #1: Open via Connection.Execute(...)
Conn1.Open AccessConnect
Set Rs1 = Conn1.Execute("SELECT * FROM Employees")
Rs1.Close
Conn1.Close
' Recordset Open Method #2: Open via Command.Execute(...)
Conn1.ConnectionString = AccessConnect
Conn1.Open
Cmd1.ActiveConnection = Conn1
Cmd1.CommandText = "SELECT * FROM Employees"
Set Rs1 = Cmd1.Execute
Rs1.Close
Conn1.Close
Conn1.ConnectionString = ""
' Recordset Open Method #3: Open w/o Connection & w/Connect String
Rs1.Open "SELECT * FROM Employees", AccessConnect, adOpenForwardOnly
Rs1.Close
Done:
Set Rs1 = Nothing
Set Cmd1 = Nothing
Set Conn1 = Nothing
Exit Sub
AdoError:
i = 1
On Error Resume Next
' Enumerate Errors collection and display properties of
' each Error object (if Errors Collection is filled out)
Set Errs1 = Conn1.Errors
For Each errLoop In Errs1
With errLoop
strTmp = strTmp & vbCrLf & "ADO Error # " & i & ":"
strTmp = strTmp & vbCrLf & " ADO Error # " & .Number
strTmp = strTmp & vbCrLf & " Description " & .Description
strTmp = strTmp & vbCrLf & " Source " & .Source
i = i + 1
End With
Next
AdoErrorLite:
' Get VB Error Object's information
strTmp = strTmp & vbCrLf & "VB Error # " & Str(Err.Number)
strTmp = strTmp & vbCrLf & " Generated by " & Err.Source
strTmp = strTmp & vbCrLf & " Description " & Err.Description
MsgBox strTmp
' Clean up gracefully without risking infinite loop in error handler
On Error GoTo 0
GoTo Done
End SubThursday, April 19, 2007 5:03 PM -
Code 14 : function to format field strings that contain apostrophes for processing by an SQL server
Function FormatSQL(StrFieldVal As String) As String
' Format Apostrophes For SQL Statement
Dim ChrPos As Long, PosFound As Long
Dim WrkStr As String
For ChrPos = 1 To Len(StrFieldVal)
PosFound = InStr(ChrPos, StrFieldVal, "'")
If PosFound > 0 Then
WrkStr = WrkStr & Mid(StrFieldVal, ChrPos, PosFound - ChrPos + 1) & "'"
ChrPos = PosFound
Else
WrkStr = WrkStr & Mid(StrFieldVal, ChrPos, Len(StrFieldVal))
ChrPos = Len(StrFieldVal)
End If
Next ChrPos
FormatSQL = WrkStr
End FunctionThursday, April 19, 2007 5:06 PM -
Code 15 : Export sql data to a CSV FilePublic Function CSVExport(db As DAO.Database, sSQL As String, sDest As String) As Boolean
Dim record As Recordset
Dim nI As Long
Dim nJ As Long
Dim nFile As Integer
Dim sTmp As String
On Error GoTo Err_Handler
Set record = db.OpenRecordset(sSQL, DAO.dbOpenDynaset, DAO.dbReadOnly)
' *** Open output file
nFile = FreeFile
Open sDest For Output As #nFile
' *** Export fields name
For nI = 0 To record.Fields.Count - 1
sTmp = "" & (record.Fields(nI).Name)
Write #nFile, sTmp;
Next
Write #nFile,
If record.RecordCount > 0 Then
record.MoveLast
record.MoveFirst
For nI = 1 To record.RecordCount
For nJ = 0 To record.Fields.Count - 1
sTmp = "" & (record.Fields(nJ))
Write #nFile, sTmp;
Next
Write #nFile,
record.MoveNext
Next
End If
Close #nFile
CSVExport = True
Exit Function
Err_Handler:
MsgBox ("Error: " & Err.Description)
CSVExport = False
End FunctionThursday, April 19, 2007 5:10 PM -
I hope its not a problem, if i post some queries also here
in one of yoru codes i saw
On Error GoTo 0 <---- uptil now i have seen On error goto LABeL, but what does this 0 mean ? if you could explain, it would be really nice.Friday, April 20, 2007 1:01 PM -
hey guys,
How to change the mouse pointer in vb from default to hand pointer style?
Friday, April 20, 2007 5:44 PM -
Hi Harshil,
Here goes answer for your query.
In VB, you can number lines. The numbering of lines starts from 1, and cannot be changed. When you write error handler statement as "On Error GoTo 0", it means that goto some undefined memory location, where no code is written for handling error, i.e., error is simply ignored.
I think that you must have got answer for your query.
Waiting for your reply,Sunday, April 22, 2007 4:16 PM -
Hey Deepak,
Here goes answer for your query.
To change mouse pointer in VB, you can use 2 methods.
1. Load pointer from one of the system defined pointers.
2. Load some cursor icon to use as a pointer.
For the 1st, the code should be :Screen.Mousepointer = 11
Here’s a list of the available Mouse Pointer properties.
Property Property Index Description
0 Default
1 Arrow
2 Cross Hairs
3 I Beam
4 Icon
5 Size
6 Size NESW
7 Size NS
8 Size NW
9 Size EW
10 Up Arrow
11 Hourglass
12 No Drop
13 Arrow and hourglass
14 Arrow and question mark
15 Size all.
99 Custom icon
For the 2nd method, the code looks like :
Object.MouseIcon = LoadPicture("PathandFileName”)Sunday, April 22, 2007 4:29 PM -
Thanks @Sanket, i have got my answer
you are too good in explaining things
thanks m8, and keep it going.
Sunday, April 22, 2007 4:39 PM -
@ Harshil,
Thanks for that good question, and really its my pleasure that I was able to answer your query..
Please post some codes here also from your side. I'm waiting for that.
@ Others
You are free to put your sample codes and ask queries here in this thread. We'll try to discuss your queries.Monday, April 23, 2007 1:22 PM -
Yes m8, i will try and find out some good sample codes, but after my exam finishes
dont get much time for anything else, still i am trying hard to take up time for this forum
Monday, April 23, 2007 2:18 PM -
And i guess the admins should appreciate us and give points to us , cause we spend lot of our precious time even during the exams for helping othersMonday, April 23, 2007 2:19 PM
-
Code 16 : Populate a combo box from a database backend without using an ADODC Control
Declarations:Dim rs as ADODB.Recordset
Dim Con as ADODB.Connection
Dim ssql as String
Const strCon =_ "DSN=Contacts;Description=Contacts;SERVER=ServerName;UID=sa;Password=;"
Code 16 : Populate a combo box from a database backend without using an ADODC Control
Code:Private Sub combo1_DropDown()
Set Con = New ADODB.Connection
Set rs = New ADODB.Recordset
Con.Open strCon
'sql statement to select items on the drop down list
ssql = "Select LastName From Contacts"
rs.Open ssql, Con
Do Until rs.EOF
combo1.AddItem rs("LastName") 'Adds lastnames to dropdown list
rs.MoveNext
Loop
'Close connection and the recordset
rs.Close
Set rs = Nothing
Con.Close
Set Con = Nothing
End SubMonday, April 23, 2007 6:02 PM -
Code 17 : Search all records with have the same category to other tablesPrivate Sub Command1_click()
Dim search as variant
sstr = InputBox("Enter Author to Search") ' Display a Input Box Window
data1.recordset.findfirst "Author='" & sstr & "'" ' Look for the record that has a value "sstr"
If trim(sstr) <> "" then
If data1.recordset.nomatch then 'check if the record exist
MsgBox "No record Exist"
Command1.setfocus
else
data1.recordsource = "SELECT * FROM TableName WHERE Author='" & sstr & "'" ' Display all the Records that has a Value of "sstr"
data1.refresh ' refresh the DBGRID or MSFLEXGRID
End if
End if
End SubMonday, April 23, 2007 6:06 PM -
Code 18 : SQL Statement, Select all Distinct Record on a Table and populate it on ComboBox or ListBoxPrivate Sub Form_Load()
Data1.Recordsource = "SELECT DISTINCT <Field> FROM <TableName>" 'Filter Fields with a unique Name
Data1.Refresh ' Refresh The Table
While Not Data1.Recordset.EOF
Combo1.AddItem Data1.Recordset("Field") 'Field on SELECT
Data1.Recordset.MoveNext ' View all Field Content
Wend
End Sub
'Note U can use (ListBox or ComboBox)
'U can also code it on CLICK Event and KEYPRESS EventMonday, April 23, 2007 6:08 PM -
Code 19 : Retreive ALL the information about Access Table & Fields using ADO
Declarations:Option Explicit
'Properties of the Catalog
Private Catalog As ADOX.Catalog
Private Col As ADOX.Column
Private Cols As ADOX.Columns
Private Grp As ADOX.Group
Private Grps As ADOX.Groups
Private Ndx As ADOX.Index
Private Ndxs As ADOX.Indexes
Private Key As ADOX.Key
Private Keys As ADOX.Keys
Private Proc As ADOX.Procedure
Private Procs As ADOX.Procedures
Private Prop As ADOX.Property
Private Props As ADOX.Properties
Private Table As ADOX.Table
Private Tables As ADOX.Tables
Private User As ADOX.User
Private Users As ADOX.Users
Private View As ADOX.View
Private Views As ADOX.Views
Public Enum TblProps
tblTempTable = 0
tblValidationText = 1
tblValidationRule = 2
tblCacheLinkNamePassword = 3
tblRemoteTableName = 4
tblLinkProviderString = 5
tblLinkDataSource = 6
tblExclusiveLink = 7
tblCreateLink = 8
tblTableHiddenInAccess = 9
End Enum
Public Enum ColProps
colAutoincrement = 0
colDefault = 1
colDescription = 2
colNullable = 3
colFixedLength = 4
colSeed = 5
colIncrement = 6
colValidationText = 7
colValidationRule = 8
colIISNotLastColumn = 9
colAutoGenerate = 10
colOneBlobPerPage = 11
colCompressedUnicode = 12
colAllowZeroLength = 13
colHyperlink = 14
End Enum
Code 19 : Retreive ALL the information about Access Table & Fields using ADOPublic Function ColumnFormat(TableName As String, Column As Variant) As Variant
Code:
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler
Set Table = Tables(TableName)
Set Cols = Table.Columns
Set Col = Cols(Column)
ColumnFormat = NumberFormat(Col.Type)
ExitHere:
Set Table = Nothing
Set Cols = Nothing
Set Col = Nothing
Exit Function
ErrHandler:
ColumnFormat = ""
Resume ExitHere
End Function
Public Function ColumnProperty(TableName As String, Column As Variant, Property As ColProps) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler
Set Table = Tables(TableName)
Set Cols = Table.Columns
Set Col = Cols(Column)
ColumnProperty = Col.Properties(Property).Value
ExitHere:
Set Table = Nothing
Set Cols = Nothing
Set Col = Nothing
Exit Function
ErrHandler:
ColumnProperty = ""
Resume ExitHere
End Function
Public Function TableProperty(TableName As String, Property As TblProps) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler
Set Table = Tables(TableName)
Set Props = Table.Properties
TableProperty = Table.Properties(Property).Value
ExitHere:
Set Table = Nothing
Set Props = Nothing
Exit Function
ErrHandler:
TableProperty = Nothing
Resume ExitHere
End Function
Private Function NumberFormat(ColType As ADODB.DataTypeEnum) As String
Select Case ColType
Case adEmpty ' 0 - No value was specified (DBTYPE_EMPTY).
Case adSmallInt: NumberFormat = "General Number" ' 2 - A 2-byte signed integer (DBTYPE_I2).
Case adInteger: NumberFormat = "General Number" ' 3 - A 4-byte signed integer (DBTYPE_I4).
Case adSingle: NumberFormat = "General Number" ' 4 - A single-precision floating point value (DBTYPE_R4).
Case adDouble: NumberFormat = "General Number" ' 5 - A double-precision floating point value (DBTYPE_R8).
Case adCurrency: NumberFormat = "Currency" ' 6 - A currency value (DBTYPE_CY). Currency is a fixed-point number with four digits to the right of the decimal point. It is stored in an 8-byte signed integer scaled by 10,000.
Case adDate: NumberFormat = "General Date" ' 7 - A Date value (DBTYPE_DATE). A date is stored as a Double, the whole part of which is the number of days since December 30, 1899, and the fractional part of which is the fraction of a day.
Case adBSTR ' 8 - A null-terminated character string (Unicode) (DBTYPE_BSTR).
Case adIDispatch ' 9 - A pointer to an IDispatch interface on an OLE object (DBTYPE_IDISPATCH).
Case adError ' 10 - A 32-bit error code (DBTYPE_ERROR).
Case adBoolean: NumberFormat = "True/False" ' 11 - A Boolean value (DBTYPE_BOOL).
Case adVariant ' 12 - An Automation Variant (DBTYPE_VARIANT).
Case adIUnknown ' 13 - A pointer to an IUnknown interface on an OLE object (DBTYPE_IUNKNOWN).
Case adDecimal: NumberFormat = "Standard" ' 14 - An exact numeric value with a fixed precision and scale (DBTYPE_DECIMAL).
Case adTinyInt: NumberFormat = "General Number" ' 16 - A 1-byte signed integer (DBTYPE_I1).
Case adUnsignedTinyInt: NumberFormat = "General Number" ' 17 - A 1-byte unsigned integer (DBTYPE_UI1).
Case adUnsignedSmallInt: NumberFormat = "General Number" ' 18 - A 2-byte unsigned integer (DBTYPE_UI2).
Case adUnsignedInt: NumberFormat = "General Number" ' 19 - A 4-byte unsigned integer (DBTYPE_UI4).
Case adUnsignedBigInt: NumberFormat = "General Number" ' 21 - An 8-byte unsigned integer (DBTYPE_UI8).
Case adBigInt: NumberFormat = "General Number" ' 20 - An 8-byte signed integer (DBTYPE_I8).
Case adGUID ' 72 - A globally unique identifier (GUID) (DBTYPE_GUID).
Case adBinary '128 - A binary value (DBTYPE_BYTES).
Case adChar '129 - A String value (DBTYPE_STR).
Case adWChar '130 - A null-terminated Unicode character string (DBTYPE_WSTR).
Case adNumeric: NumberFormat = "General Number" '131 - An exact numeric value with a fixed precision and scale (DBTYPE_NUMERIC).
Case adUserDefined '132 - A user-defined variable (DBTYPE_UDT).
Case adDBDate: NumberFormat = "General Date" '133 - A date value (yyyymmdd) (DBTYPE_DBDATE).
Case adDBTime: NumberFormat = "Long Time" '134 - A time value (hhmmss) (DBTYPE_DBTIME).
Case adDBTimeStamp: NumberFormat = "General Date" '135 - A date-time stamp (yyyymmddhhmmss plus a fraction in billionths) (DBTYPE_DBTIMESTAMP).
Case adVarChar '200 - A String value (Parameter object only).
Case adLongVarChar '201 - A long String value (Parameter object only).
Case adVarWChar '202 - A null-terminated Unicode character string (Parameter object only).
Case adLongVarWChar '203 - A long null-terminated string value (Parameter object only).
Case adVarBinary '204 - A binary value (Parameter object only).
Case adLongVarBinary '205 - A long binary value (Parameter object only).
End Select
End Function
Private Function SetCatalog() As ADOX.Catalog
'Retrieves the description of the field
'Cat.Tables(1).Columns(1).Properties(2).Value
'Set DBCatalog = Cat
'Set Cat = Nothing
If Not Catalog Is Nothing Then
End If
End Function
Private Sub Class_Initialize()
'Create the Catlog
Set Catalog = New ADOX.Catalog
Catalog.ActiveConnection = cnADO
Set Tables = Catalog.Tables
Set Users = Catalog.Users
Set Views = Catalog.Views
Set Procs = Catalog.Procedures
Set Grps = Catalog.Groups
End Sub
Private Sub Class_Terminate()
Set Col = Nothing
Set Cols = Nothing
Set Grp = Nothing
Set Grps = Nothing
Set Ndx = Nothing
Set Ndxs = Nothing
Set Key = Nothing
Set Keys = Nothing
Set Proc = Nothing
Set Procs = Nothing
Set Prop = Nothing
Set Props = Nothing
Set Table = Nothing
Set Tables = Nothing
Set User = Nothing
Set Users = Nothing
Set View = Nothing
Set Views = Nothing
Set Catalog = Nothing
End SubMonday, April 23, 2007 6:24 PM -
Code 20 : Create a MS Access database using 4 lines of code'set a reference to the Microsoft DAO 3.5 Object library then use the code below
Dim ws As Workspace
Dim db As Database
Set ws = DBEngine.Workspaces(0)
'substitute Password with the desired password
Set db = ws.CreateDatabase("test.mdb", dbLangGeneral & ";pwd=Password")Monday, April 23, 2007 6:26 PM -
Code 21 : Use Format/UnFormat events of Format Object in VB6Option Explicit
'Binds TextBox controls to the ADO control.
Dim bc As New BindingCollection
'
'We'll add code to Format/UnFormat events on this object.
Dim WithEvents fProduct As StdDataFormat
Dim msOrigProductName As String 'For saved data.
Private Sub Form_Load()
'Connect the BindingCollection object to the datasource.
Set bc.DataSource = Adodc1
Set fProduct = New StdDataFormat
bc.Add txtProduct, "Text", "ProductName", fProduct, "product"
End Sub
Private Sub fProduct_Format(ByVal DataValue As StdFormat.StdDataValue)
'
Debug.Print "Formated ProductName: " & DataValue.Value
'
'Save the original value of ProductName.
msOrigProductName = DataValue.Value
'
'Change it to upper case and then sent to data-bound control.
DataValue.Value = UCase(DataValue.Value)
'
End Sub
Private Sub fProduct_UnFormat(ByVal DataValue As StdFormat.StdDataValue)
'
'Always write the saved data back to DB so that no data was changed.
DataValue.Value = msOrigProductName
'
End SubMonday, April 23, 2007 6:29 PM -
Code 22 : writes the contents of an ADO RecordSet to a ascii text file with user specified column & row delimiters
Option Explicit
Private iFileNumber As Integer
Private sFilePath As String
Private sDelimeter As String
Private sRowDelimeter As String
Private lErrorNumber As Long
Private sErrorDescription As String
Private sErrorPlace As String
Public Property Get GetErrorNumber() As Long
GetErrorNumber = lErrorNumber
End Property
Public Property Get GetErrorDescription() As String
GetErrorDescription = sErrorDescription
End Property
Public Property Get GetErrorPlace() As String
GetErrorPlace = sErrorPlace
End Property
Public Property Let FilePath(ByVal inFilePath As String)
sFilePath = inFilePath
End Property
Public Property Get GetFilePath() As String
GetFilePath = sFilePath
End Property
Public Property Let Delimeter(ByVal inDelimeter As String)
sDelimeter = inDelimeter
End Property
Public Property Get GetDelimeter() As String
GetDelimeter = sDelimeter
End Property
Public Property Let RowDelimeter(ByVal inRowDelimeter As String)
sRowDelimeter = inRowDelimeter
End Property
Public Property Get GetRowDelimeter() As String
GetRowDelimeter = sRowDelimeter
End Property
Public Function Write2File(Optional ByRef inRecordSet As ADODB.Recordset, _
Optional ByRef inFilePath As String, _
Optional ByRef inDelimeter As String, _
Optional ByRef inRowDelimeter As String, _
Optional ByRef inAppend As Boolean, _
Optional ByRef inHeaderRecord As String) As Long
On Error GoTo ErrorHandler
'Default: Delimeter is ","
' RowDelimeter is VBCrLF
Dim sTempRecord As String
Dim dRecords As Double
Dim dIndex As Double
Dim iCol As Integer
Dim iMaxCols As Integer
'Check if anything to do
If (IsEmpty(inRecordSet)) Then
Exit Function
Else
If (inRecordSet.RecordCount = 0) Then
Exit Function
Else
dRecords = inRecordSet.RecordCount
End If
End If
'File Path
If (Len(inFilePath) > 0) Then
sFilePath = inFilePath
Else
If (Len(sFilePath) < 1) Then
Exit Function
End If
End If
'Set up the Column Delimeter
If (Len(inDelimeter) > 0) Then
sDelimeter = inDelimeter
Else
If (Len(sDelimeter) < 1) Then
sDelimeter = ","
End If
End If
'Set up the Row Delimeter
If (Len(inRowDelimeter) > 0) Then
sRowDelimeter = inRowDelimeter
Else
If (Len(sRowDelimeter) < 1) Then
sRowDelimeter = vbCrLf
End If
End If
Call OpenFile(inAppend)
If (Len(inHeaderRecord) > 0) Then
Print #iFileNumber, inHeaderRecord
End If
iMaxCols = inRecordSet.Fields.Count - 1
inRecordSet.MoveFirst
'This if statement is to accomodate a bug in .movenext
'where the record set only contains one record...
If (dRecords = 1) Then
sTempRecord = inRecordSet.Fields(0).Value
For iCol = 1 To iMaxCols
sTempRecord = sTempRecord & sDelimeter & inRecordSet.Fields(iCol).Value
Next iCol
Print #iFileNumber, sTempRecord
Else
While dIndex < dRecords
sTempRecord = inRecordSet.Fields(0).Value
For iCol = 1 To iMaxCols
sTempRecord = sTempRecord & sDelimeter & inRecordSet.Fields(iCol).Value
Next iCol
Print #iFileNumber, sTempRecord
dIndex = dIndex + 1
inRecordSet.MoveNext
Wend
End If
CloseFile
DoEvents
Exit Function
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "OpenInterfaceFile()"
End Function
Private Sub OpenFile(ByRef inAppend As Boolean)
On Error GoTo ErrorHandler
iFileNumber = FreeFile
If (inAppend) Then
'Check if Error file already exists
If (Dir(sFilePath) = "") Then
Open sFilePath For Output As #iFileNumber
Else
Open sFilePath For Append As #iFileNumber
End If
Else
Open sFilePath For Output As #iFileNumber
End If
Exit Sub
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "OpenLogFile()"
End Sub
Private Sub CloseFile()
On Error GoTo ErrorHandler
Close #iFileNumber
Exit Sub
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseInterfaceFile()"
End SubMonday, April 23, 2007 6:31 PM -
Code 23 : Simplifies ADO 2.x access
Option Explicit
Private Const ConstCommandTimeout = 60
Private Const ConstDatabaseTimeout = 60
Private oDBConnection As New ADODB.Connection
Private oADOCommand As New ADODB.Command
Private oDbRecordSet As New ADODB.Recordset
Attribute oDbRecordSet.VB_VarHelpID = -1
Private iADODatabaseTimeout As Integer
Private iADOCommandTimeout As Integer
Private iCacheSize As Integer
Private lResult As Long
Private sDSN As String
Private sUserName As String
Private sPassword As String
Private sDatabase As String
Private lErrorNumber As Long
Private sErrorDescription As String
Private sErrorPlace As String
Private sODBCString As String
Private sProviderString As String
Private bLogFile As Boolean
Private sLogFilePath As String
Private iLogFileNumber As Integer
Private sSQLString As String
Private bProviderConnection As Boolean
Private bLogging As Boolean
Public Property Let LogFilePath(ByVal vData As String)
sLogFilePath = vData
End Property
Public Property Get LogFilePath() As String
LogFilePath = sLogFilePath
End Property
Public Property Let Logging(ByVal vData As Boolean)
bLogging = vData
End Property
Public Property Get Logging() As Boolean
Logging = bLogging
End Property
Public Property Get Connection() As ADODB.Connection
Set Connection = oDBConnection
End Property
Public Sub Class_Initialize()
On Error GoTo errhandler
Call Initialize
Exit Sub
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Class_Initialize()"
End Sub
Private Sub Initialize()
bLogging = False
iADOCommandTimeout = ConstCommandTimeout
iADODatabaseTimeout = ConstDatabaseTimeout
sDSN = ""
sUserName = ""
sPassword = ""
sDatabase = ""
sODBCString = ""
sSQLString = ""
lErrorNumber = 0
sErrorDescription = ""
sErrorPlace = ""
sODBCString = ""
sProviderString = ""
sSQLString = ""
sLogFilePath = ""
End Sub
Public Sub Class_Terminate()
Call Initialize
If (oDBConnection.State = 1) Then
Me.CloseConnection
End If
End Sub
Public Property Get VersionInfo() As String
VersionInfo = App.Path + "\" + App.EXEName + "." + TypeName(Me) + _
" " + CStr(App.Major) + _
" . " + CStr(App.Minor) + " . " + CStr(App.Revision)
End Property
Public Property Get GetErrorNumber() As Long
GetErrorNumber = lErrorNumber
End Property
Public Property Get GetErrorDescription() As String
GetErrorDescription = sErrorDescription
End Property
Public Property Get GetErrorPlace() As String
GetErrorPlace = sErrorPlace
End Property
Public Property Let DSN(ByVal inDSN As String)
sDSN = inDSN
End Property
Public Property Get DSN() As String
DSN = sDSN
End Property
Public Property Get RecordCount() As Integer
RecordCount = oDbRecordSet.RecordCount
End Property
Public Property Let CacheSize(ByVal inCacheSize As Integer)
iCacheSize = inCacheSize
End Property
Public Property Get CacheSize() As Integer
CacheSize = iCacheSize
End Property
Public Property Let MaxRecords(ByVal inMaxRecords As Double)
On Error GoTo errhandler
If (inMaxRecords > 0) Then
oDbRecordSet.MaxRecords = inMaxRecords
End If
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let MaxRecords()"
End Property
Public Property Get MaxRecords() As Double
On Error GoTo errhandler
MaxRecords = oDbRecordSet.MaxRecords
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get MaxRecords()"
End Property
Public Property Let ProviderConnection(ByVal inValue As Boolean)
On Error GoTo errhandler
bProviderConnection = inValue
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ProviderConnection()"
End Property
Public Property Get ProviderConnection() As Boolean
On Error GoTo errhandler
ProviderConnection = bProviderConnection
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ProviderConnection()"
End Property
Public Property Let ADODatabaseTimeout(ByVal inADODatabaseTimeout As Integer)
On Error GoTo errhandler
iADODatabaseTimeout = inADODatabaseTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ADODatabaseTimeout()"
End Property
Public Property Get ADODatabaseTimeout() As Integer
On Error GoTo errhandler
ADODatabaseTimeout = iADODatabaseTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ADODatabaseTimeout()"
End Property
Public Property Let ADOCommandTimeout(ByVal inADOCommandTimeout As Integer)
On Error GoTo errhandler
iADOCommandTimeout = inADOCommandTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ADOCommandTimeout()"
End Property
Public Property Get ADOCommandTimeout() As Integer
On Error GoTo errhandler
ADOCommandTimeout = iADOCommandTimeout
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ADOCommandTimeout()"
End Property
Public Property Let UserName(ByVal inUserName As String)
On Error GoTo errhandler
sUserName = inUserName
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let UserName()"
End Property
Public Property Get UserName() As String
On Error GoTo errhandler
UserName = sUserName
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get UserName()"
End Property
Public Property Let Password(ByVal inPassword As String)
On Error GoTo errhandler
sPassword = inPassword
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let Password()"
End Property
Public Property Get Password() As String
On Error GoTo errhandler
Password = sPassword
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get Password()"
End Property
Public Property Let Database(ByVal inDatabase As String)
On Error GoTo errhandler
sDatabase = inDatabase
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let Database()"
End Property
Public Property Get Database() As String
On Error GoTo errhandler
Database = sDatabase
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get Database()"
End Property
Public Property Let Provider(ByVal inProviderString As String)
On Error GoTo errhandler
sProviderString = inProviderString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let Provider()"
End Property
Public Property Get Provider() As String
On Error GoTo errhandler
Provider = sProviderString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get Provider()"
End Property
Public Property Let ODBCString(ByVal inODBCString As String)
On Error GoTo errhandler
sODBCString = inODBCString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ODBCString()"
End Property
Public Property Get ODBCString() As String
On Error GoTo errhandler
ODBCString = sODBCString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ODBCString()"
End Property
Public Property Let SQLString(ByVal inSQLString As String)
On Error GoTo errhandler
sSQLString = inSQLString
oADOCommand.CommandText = sSQLString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let SQLString()"
End Property
Public Property Get SQLString() As String
On Error GoTo errhandler
SQLString = sSQLString
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get SQLString()"
End Property
Public Property Let ADOCommandText(ByVal inText As String)
On Error GoTo errhandler
oADOCommand.CommandText = inText
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Let ADOCommandText()"
End Property
Public Property Get ADOCommandText() As String
On Error GoTo errhandler
ADOCommandText = oADOCommand.CommandText
Exit Property
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get ADOCommandText()"
End Property
Public Function SetODBCString(Optional ByVal inDSN As String, Optional ByVal inUserName As String, Optional ByVal inPassword As String, Optional ByVal inDatabase As String) As Boolean
On Error GoTo errhandler
Dim TheDSN As String
Dim TheUserName As String
Dim ThePassword As String
Dim TheDatabase As String
SetODBCString = False
If (inDSN = "") Then
If (sDSN = "") Then
Exit Function
Else
TheDSN = sDSN
End If
Else
TheDSN = inDSN
End If
If (inUserName = "") Then
If (sUserName = "") Then
Exit Function
Else
TheUserName = sUserName
End If
Else
TheUserName = inUserName
End If
If (inPassword = "") Then
If (sPassword = "") Then
Exit Function
Else
ThePassword = sPassword
End If
Else
ThePassword = inPassword
End If
If (inDatabase = "") Then
If (sDatabase = "") Then
Exit Function
Else
TheDatabase = sDatabase
End If
Else
TheDatabase = inDatabase
End If
sODBCString = "DSN=" & TheDSN & ";uid=" & TheUserName & ";pwd=" & ThePassword & ";database=" & TheDatabase
SetODBCString = True
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Set SetODBCString()"
SetODBCString = False
End Function
Public Function GetState() As Integer
On Error GoTo errhandler
GetState = oDBConnection.State
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "Get State()"
GetState = lErrorNumber
End Function
Public Function OpenODBCConnection() As Long
On Error GoTo errhandler
If (ODBCString = "") Then
OpenODBCConnection = -2
Else
oDBConnection.Open sODBCString
If (oDBConnection.State = 1) Then
Set oADOCommand.ActiveConnection = oDBConnection
oDbRecordSet.CursorLocation = adUseClient
OpenODBCConnection = 0 'OK
Else
OpenODBCConnection = -1 'Error
End If
End If
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CRVADOAccess.OpenODBCConnection()"
OpenODBCConnection = lErrorNumber
End Function
Public Function OpenProviderConnection() As Long
On Error GoTo errhandler
If (sProviderString = "") Then
OpenProviderConnection = -2
Else
oDBConnection.Open sProviderString
If (oDBConnection.State = 1) Then
oDbRecordSet.CursorLocation = adUseClient
Set oADOCommand.ActiveConnection = oDBConnection
OpenProviderConnection = 0 'OK
Else
OpenProviderConnection = -1 'Error
End If
End If
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CRVADOAccess.OpenProviderConnection()"
OpenProviderConnection = lErrorNumber
End Function
Public Function SubmitQuery(Optional ByRef inSQLString As String, _
Optional ByRef inCursor As String) As Long
On Error GoTo errhandler
Dim sCursor As String
If (Len(inCursor) > 0) Then
sCursor = inCursor
Else
sCursor = adOpenForwardOnly
End If
'Check if Connected
If (oDBConnection.State = 0) Then 'Not Connected
If (ProviderConnection) Then
lResult = OpenProviderConnection
Else
lResult = OpenODBCConnection
End If
If (lResult <> 0) Then
Exit Function
End If
End If
'Check if Record Set Open
If (oDbRecordSet.State <> 0) Then 'RecordSet is open
oDbRecordSet.Close
End If
'Check if SQL in method call
If (inSQLString = "") Then
If (bLogging) Then
WriteLogRecord oADOCommand.CommandText
End If
oDbRecordSet.Open oADOCommand, oDBConnection, sCursor
Else
If (bLogging) Then
WriteLogRecord inSQLString
End If
oADOCommand.CommandText = inSQLString
oDbRecordSet.Open oADOCommand
'Debug.Print oDbRecordSet.RecordCount
End If
SubmitQuery = 0 'Return OK
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "SubmitQuery()"
If (bLogging) Then
WriteLogRecord lErrorNumber & " " & sErrorDescription
End If
SubmitQuery = lErrorNumber 'Return Error
End Function
Public Function ADOCommandExecute() As Integer
On Error GoTo errhandler
oADOCommand.Execute
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "ADOCommandExecute()"
End Function
Public Function RetrieveRecordSet() As ADODB.Recordset
On Error GoTo errhandler
'This function returns a clone of the recordset
Set RetrieveRecordSet = oDbRecordSet.Clone
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "RetrieveRecordSet()"
Set RetrieveRecordSet = Nothing
End Function
Public Function RetrieveRecordSetPointer() As ADODB.Recordset
On Error GoTo errhandler
'This function returns a pointer to the recordset
Set RetrieveRecordSetPointer = oDbRecordSet
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "RetrieveRecordSetPointer()"
Set RetrieveRecordSetPointer = Nothing
End Function
Public Function CloseRecordSet() As Long
On Error GoTo errhandler
If (oDbRecordSet.State = 1) Then
oDbRecordSet.Close
End If
CloseRecordSet = oDbRecordSet.State
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseConnection()"
End Function
Public Function CloseConnection() As Long
On Error GoTo errhandler
If (oDBConnection.State = 1) Then
oDBConnection.Close
CloseConnection = 0
Else
CloseConnection = -1
End If
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseConnection()"
End Function
Public Function MoveFirst() As Boolean
On Error GoTo errhandler
oDbRecordSet.MoveFirst
MoveFirst = True
Exit Function
errhandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "MoveFirst()"
MoveFirst = False
End Function
Private Sub WriteLogRecord(inSQL As String)
On Error Resume Next
iLogFileNumber = FreeFile
'Check if file already exists
If (Dir(sLogFilePath) = "") Then
Open sLogFilePath For Output As #iLogFileNumber
Else
Open sLogFilePath For Append As #iLogFileNumber
End If
'Write out the record
Print #iLogFileNumber, inSQL
Close #iLogFileNumber
End SubMonday, April 23, 2007 6:34 PM -
Code 24 : code for saving into a file what is in listboxSub Savelist(list as listbox, name as string)
for i = 0 to list.listcount -1
data$ = list.list(i)
open name for output as #1
print #1, data$
close 1
next i
End SubMonday, April 23, 2007 6:36 PM -
Code 25 : Save ADO Recordset data in XML format filePrivate Sub Command1_Click()
'
'Modified from Microsoft KB sample.
'You need to have ADO 2.1 installed on your machine and set reference to it first.
'
Dim Rst1 As New ADODB.Recordset
Dim Rst2 As New ADODB.Recordset
'
Rst1.Fields.Append "xx1", adInteger
Rst1.Fields.Append "xx2", adChar, 5
Rst1.Fields.Refresh
'
'Add something to it. Have to open it first.
Rst1.Open
Rst1.AddNew
Rst1.Fields(0).Value = 1
Rst1.Fields(1).Value = "NAME1"
Rst1.Update
'
Kill "C:\Recordset.XML"
'
'Persist data in Recordset to an XML file
Rst1.Save "c:\Recordset.xml", adPersistXML
Rst1.Close
Set Rst1 = Nothing
'
'Read XML file data into Recordset.
Rst2.Open "c:\Recordset.xml"
Do Until Rst2.EOF
Debug.Print Rst2(0), Rst2(1)
Rst2.MoveNext
Loop
'
Rst2.Close
Set Rst2 = Nothing
'
'If you have IE5 on your machine, you can use it to open this xml file.
'
End SubMonday, April 23, 2007 6:39 PM -
Code 26 : A easy way to get data from MSAccess parameter query into ADO RecordsetPrivate Sub Command1_Click()
'
'Set reference to ADO library first.
'In my test, the parameter query will return all records in table PRODUCTS
'whoes ProductID <= the passed value. It looks like this:
'SELECT Products.* FROM Products WHERE (Products.ProductID<=IDMax);
'
Dim Cnn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
'
'Open a Connection using an ODBC DSN.
Cnn.Open "DSN=adoobj;UID=;PWD=;"
'
'All records whose ProductID <= 3 will be returned.
Set Rst = Cnn.Execute("qry_storedproc 3", , adCmdStoredProc)
'
Do While Not Rst.EOF
Debug.Print Rst(0)
Rst.MoveNext
Loop
'
Set Rstc = Nothing
Set Cnn = Nothing
'
End SubMonday, April 23, 2007 6:41 PM -
Code 27 : pass parameters to stored procedures of Oracle when using Command.Execute method in ADO'From MSDN online help sample, if you want to pass parameters to a stored
'procedure, you need to create parameter objects, append them to ADO Command
'object, and then assign the values. But I found an easy way to do the same
'work if you are going to call procedures in Oracle. In the same method, you can
'return from an Oracle PL/SQl function.
'
Dim strSQL As String
Dim qryStoredProc As New ADODB.Command
Dim id As Long
Dim name As String
'
With qryStoredProc
.CommandText = "scott.instrec"
.CommandType = adCmdStoredProc
.ActiveConnection = mCnn 'Suppose that you already have a valid one.
End With
'
id = CLng(InputBox("Enter an integer below:"))
name = InputBox("Enter the name:")
'
'Insert a new record into Oracle table.
qryStoredProc(0) = id
qryStoredProc(1) = name
qryStoredProc.Execute
'
'The first parameter is InOut and the other is Out.
MsgBox "ParamInOut: " & qryStoredProc(0) & _
NL & "ParamOut: " & qryStoredProc(2)
'----------------------------------------------------------
'The Oracle table MYTEST has only two cols: MYID and MYTEST
'The code for the stored procedure is listed below.
'
'procedure instrec (
' p_id in out number, p_name in varchar2,
' p_id_plus out number
' ) AS
'BEGIN
' insert into mytest values(p_id, p_name);
' commit;
' -- Testing only
' p_id_plus:=p_id+1;
' p_id:=p_id+1;
'END instrec;
Monday, April 23, 2007 6:43 PM -
Code 28 : A speedy way to find how many rows are in a large table
'Suppose you already set refernece to ADO library, and objCnn is a opened
'Connection object, using ODBC driver.
'
'Benefits:
'1. If the table is very large, this way will be very fast. In my test,
'a MSAccess table has almost 180K records. Once I have a active Connection
'object, it took about one second to get the count of records. If I use
'ADODB.Recordset to open the table and then use Recordset.RecordCount property
'to do the same job, it took more than 50 seconds.
'2. In case the Recordset dose not support adApproxPosition or adBookmark, like
'my case using ODBC driver for Oracle, you can use this.
'Anyone has better way to do this, please let me know. I'll appreciate your
'generosity.
'
'I think it will work for VBScripts or ASP too.
'
Public Function plGetRecCount(objCnn As ADODB.Connection, sTBL As String) As Long
'
Dim Rst As New ADODB.Recordset
Dim lRecCount As Long
Dim sSQL As String
'
On Error GoTo Err_Handler
'
sSQL = "SELECT Count(*) As RecNum From " & sTBL
'
Set Rst = objCnn.Execute(sSQL)
'
lRecCount = Rst.Fields("RecNum")
plGetRecCount = lRecCount
'
Rst.Close
Set Rst = Nothing
'
Exit Function
'
Err_Handler:
'
plGetRecCount = -1
MsgBox objCnn.Errors(0).Description
'
End FunctionMonday, April 23, 2007 6:47 PM -
Code 29 : Using ADO, transfering the content(records) of one table to another.Private Sub Command1_Click()
Dim icounter As Integer
Dim dtart As Double, dfinish As Double
Dim pnlstatus As Panel
Static i As Integer
Set pnlstatus = Form1.StatusBar1.Panels(1)
dstart = Timer
Adodc1.Refresh
Adodc2.Refresh
On Error Resume Next
ProgressBar1.Visible = True
pnlstatus.Text = "Transfering data please wait...."
StatusBar1.Refresh
ProgressBar1.Max = Val(Text1.Text)
For icounter = 1 To Val(Text1.Text)
If icounter Mod 10 = 0 Then ProgressBar1.Value = icounter
Next icounter
pnlstatus.Text = "Transfer Complete...."
StatusBar1.Refresh
'transfer the record to new table
For i = 0 To Adodc1.Recordset.RecordCount
Adodc2.Recordset.AddNew
Adodc2.Recordset("EmpNum") = Adodc1.Recordset("Empnum")
Adodc2.Recordset("EmpName") = Adodc1.Recordset("EmpName")
Adodc1.Recordset.MoveNext
Next i
Adodc1.Refresh
Adodc2.Refresh
'delete the record after transfering
For i = 0 To Adodc1.Recordset.RecordCount
Adodc1.Recordset.Delete
Adodc1.Recordset.MoveNext
Next i
'end of deletion
dfinish = Timer
pnlstatus.Text = "Ready..."
ProgressBar1.Value = 0
ProgressBar1.Visible = False
Command2.Enabled = True
Command1.Enabled = False
End Sub
Private Sub Command2_Click()
Dim icounter As Integer
Dim dtart As Double, dfinish As Double
Dim pnlstatus As Panel
Static i As Integer
Set pnlstatus = Form1.StatusBar1.Panels(1)
dstart = Timer
Adodc1.Refresh
Adodc2.Refresh
On Error Resume Next
ProgressBar1.Visible = True
pnlstatus.Text = "Returning data please wait...."
StatusBar1.Refresh
ProgressBar1.Max = Val(Text1.Text)
For icounter = 1 To Val(Text1.Text)
If icounter Mod 10 = 0 Then ProgressBar1.Value = icounter
Next icounter
pnlstatus.Text = "Return Complete...."
StatusBar1.Refresh
'transfer the record to new table
For i = 0 To Adodc2.Recordset.RecordCount
Adodc1.Recordset.AddNew
Adodc1.Recordset("EmpNum") = Adodc2.Recordset("Empnum")
Adodc1.Recordset("EmpName") = Adodc2.Recordset("EmpName")
Adodc2.Recordset.MoveNext
Next i
Form1.Adodc1.Refresh
Form1.Adodc2.Refresh
'delete the record after transfering
For i = 0 To Adodc2.Recordset.RecordCount
Adodc2.Recordset.Delete
Adodc2.Recordset.MoveNext
Next i
'end of deletion
dfinish = Timer
pnlstatus.Text = "Ready..."
ProgressBar1.Value = 0
ProgressBar1.Visible = False
Command2.Enabled = False
Command1.Enabled = True
End Sub
Private Sub Command3_Click()
End
End SubMonday, April 23, 2007 6:50 PM -
Code 30 : Using ADO to open an Access MDB DSN-lessDim CN1 as New ADODB.Connection
Dim RS1 as New ADODB.Recordset
Dim sSQL as String
CN1.CursorLocation = adUseClient
CN1.Provider = "Microsoft.Jet.OLEDB.4.0"
CN1.Open App.Path & "\MyDatabase.MDB", "", ""
sSql = "Select * From Address Order By [LName]"
RS1.Open sSql, CN1, adOpenDynamic, adLockOptimistic, adCmdTextMonday, April 23, 2007 6:52 PM -
Code 31 : Saving ADO Recordset to a text file with user-defined requirements such as col/row delimiters'Just make use of the ADODB.Recordset.GetString method. You can modify this
'function by setting some of those parameters to Optional to make it more
'flexible and meet your own need. I am just lazy.
Public Sub SaveRecInText(RstPrm As ADODB.Recordset, _
FileSpec As String, RowCount As Long, _
ColDeli As String, RowDeli As String, _
NullRep As String)
'
Dim sBuffer As String
Dim FileNum As Long
'
sBuffer = RstPrm.GetString(adClipString, RowCount, ColDeli, RowDeli, NullRep)
'
'Remove the file first if it exists.
If Len(Dir(FileSpec)) > 0 Then
Kill FileSpec
End If
'
FileNum = FreeFile
Open FileSpec For Binary As FileNum
Put FileNum, , sBuffer
Close FileNum
'
End SubMonday, April 23, 2007 6:55 PM -
Code 32 : Stores any binary data into the Database field. ex: zip files, exe files, images etc
'------------ Put this into a module ---------------------
Function CopyFieldToFile(rst As DAO.Recordset, fd As String, strFileName As String) As String
Dim FileNum As Integer
Dim Buffer() As Byte
Dim BytesNeeded As Long
Dim Buffers As Long
Dim Remainder As Long
Dim Offset As Long
Dim r As Integer
Dim i As Long
Dim ChunkSize As Long
ChunkSize = 65536
BytesNeeded = rst(fd).FieldSize
If BytesNeeded > 0 Then
' Calculate the number of buffers needed to copy
Buffers = BytesNeeded \ ChunkSize
Remainder = BytesNeeded Mod ChunkSize
' Get a unique, temporary filename:
If Dir(strFileName) <> "" Then
Kill strFileName
End If
' Copy the bitmap to the temporary file chunk by chunk:
FileNum = FreeFile
Open strFileName For Binary As #FileNum
For i = 0 To Buffers - 1
ReDim Buffer(ChunkSize)
Buffer = rst(fd).GetChunk(Offset, ChunkSize)
Put #FileNum, , Buffer()
Offset = Offset + ChunkSize
Next ' Copy the remaining chunk of the bitmap to the file:
ReDim Buffer(Remainder)
Buffer = rst(fd).GetChunk(Offset, Remainder)
Put #FileNum, , Buffer()
Close #FileNum
End If
CopyFieldToFile = strFileName
End Function
Function CopyFileToField(FileName As String, fd As DAO.Field)
Dim ChunkSize As Long
Dim FileNum As Integer
Dim Buffer() As Byte
Dim BytesNeeded As Long
Dim Buffers As Long
Dim Remainder As Long
Dim i As Long
If Len(FileName) = 0 Then
Exit Function
End If
If Dir(FileName) = "" Then
Err.Raise vbObjectError, , "File not found: """ & FileName & """"
End If
ChunkSize = 65536
FileNum = FreeFile
Open FileName For Binary As #FileNum
BytesNeeded = LOF(FileNum)
Buffers = BytesNeeded \ ChunkSize
Remainder = BytesNeeded Mod ChunkSize
For i = 0 To Buffers - 1
ReDim Buffer(ChunkSize)
Get #FileNum, , Buffer
fd.AppendChunk Buffer
Next
ReDim Buffer(Remainder)
Get #FileNum, , Buffer
fd.AppendChunk Buffer
Close #FileNum
End Function
'----------- Use of CopyFieldToFile ----------------
1. You must have a recordset open.
Call CopyFieldToFile <recordset>, "<Field>", "<Filename>"
'----------- Use of CopyFileToField ----------------
1. You must have a recordset open.
Call CopyFileToField "<Filename>", "<FieldToWriteTheFileTo>"Monday, April 23, 2007 6:59 PM -
very awesome work m8, i really liked the cod number 32
One doubt, what does KILL do ? Never came across such a statement in vb
and btw, i am learning lot of new things that i didn't even knew, after you started this thread.Tuesday, April 24, 2007 12:56 PM -
Kill statement is used to delete a file.
But its very dangerous as it will not have any undo facility. It means that once you have deleted any file / files using it, its not possible to recover the deleted file.Tuesday, April 24, 2007 6:57 PM -
Code 33 : List Database names of by Driver type and server name using ADOPublic Sub GetDatabases(strDriver As String, strServer As String, cboToFill As ComboBox)
Dim cn As New ADODB.Connection
Dim rsSchema As New ADODB.Recordset
Dim ConnStr As String
ConnStr = "driver={" & strDriver & "};"
ConnStr = ConnStr & "server=" & strServer & ";"
ConnStr = ConnStr & "uid=sa;pwd=;"
cn.ConnectionString = ConnStr
cn.Open
Set rsSchema = cn.OpenSchema(adSchemaCatalogs)
Do Until rsSchema.EOF
cboToFill.AddItem rsSchema!Catalog_Name
rsSchema.MoveNext
Loop
End SubTuesday, April 24, 2007 7:13 PM -
Code 34 : Retrieving Access 97 password.
DeclarationsDim n As Long, s1 As String * 1, s2 As String * 1
Dim lsClave As String
Dim mask As String
Code 34 : Retrieving Access 97 password.
Codemask = Chr(78) & Chr(134) & Chr(251) & Chr(236) & _
Chr(55) & Chr(93) & Chr(68) & Chr(156) & _
Chr(250) & Chr(198) & Chr(94) & Chr(40) & Chr(230) & Chr(19)
Open "c:\protected db.mdb" For Binary As #1
Seek #1, &H42
For n = 1 To 14
s1 = Mid(mask, n, 1)
s2 = Input(1, 1)
If (Asc(s1) Xor Asc(s2)) <> 0 Then
lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2))
End If
Next
Close 1
MsgBox "The Password Is: " & lsClaveTuesday, April 24, 2007 7:17 PM -
Code 35 : whenever Database has been modified check if it was and refreshes contents
DeclarationsPublic rst as ADODB.Recordset
Public db as ADODB.Connection
Code 35 : whenever Database has been modified check if it was and refreshes contents
Code''I used this Code to for Updating the TreeView after change has
been made in
''the database.
Private Sub cmdConnect_Click()
Set db = New ADODB.Connection
Set rst = New ADODB.Recordset
db.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=d:\hfs200.mdb"
rst.Open "SELECT tblManifest.Container, tblManifest.Seal,
tblManifest.Origin FROM tblManifest;", db, adOpenDynamic, adLockOptimistic
varRst = rst.GetRows
rst.MoveFirst
End Sub
Private Sub Timer1_Timer()
Set db = New ADODB.Connection
Set rst = New ADODB.Recordset
db.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=d:\hfs200.mdb"
rst.Open "SELECT tblManifest.Container, tblManifest.Seal,
tblManifest.Origin FROM tblManifest;", db, adOpenDynamic, adLockOptimistic
varRst2 = rst.GetRows
rst.MoveFirst
Call CompareVars ''Here we call Matching Subroutine.
End Sub
Sub CompareVars()
dim x as long
dim y as long
dim cols as long
for x = 0 to UBound(varRst, 2)
for cols = 0 to Ubound(varRst, 1)
if varRst(cols, x) <> varRST2(cols, x) then
''Here i call TreeView Refresh because we found the change.
cmdConnect.Value = True ''Clicks the Button to connect.
end if
next
next
End SubTuesday, April 24, 2007 7:21 PM -
Code 36 : Extract the data from an ADO Recordset into a 2-D variant arrayFunction RecordsetToVarArray(oRst As ADODB.Recordset) As Variant()
Dim avarStuff() As Variant ' Hold the returned records
Dim fldThis As ADODB.Field ' Iterator for the Fields collection
Dim iIndex As Integer ' Loop index
' Resize the array to hold the column names
ReDim avarStuff(1 To oRst.Fields.Count, 0 To 0) As Variant
' Extract all the column names from the Fields collection
iIndex = 1
For Each fldThis In oRst.Fields
avarStuff(iIndex, 0) = fldThis.Name
iIndex = iIndex + 1
Next fldThis
' Move to the first record in the recordset
oRst.MoveFirst
' Loop through the records, and build the 2-D array
Do While Not oRst.EOF
ReDim Preserve avarStuff(LBound(avarStuff, 1) To UBound(avarStuff, 1), _
LBound(avarStuff, 2) To (UBound(avarStuff, 2) + 1)) As Variant
For iIndex = LBound(avarStuff, 1) To UBound(avarStuff, 1)
avarStuff(iIndex, UBound(avarStuff, 2)) = _
oRst.Fields(avarStuff(iIndex, 0)).Value
Next iIndex
oRst.MoveNext
Loop
' Return the array
RecordsetToVarArray = avarStuff()
End FunctionTuesday, April 24, 2007 7:24 PM -
Hi Sanket ur forum is working excellently!!!
well can u explain me how to add the image files in the database(Ms Access)?
which datatype i have put in that field?
and how to load it from vb?
Thursday, April 26, 2007 5:16 PM -
Very awesome m8, i also agree that your thread is SUPERPFriday, April 27, 2007 12:34 PM
-
can we create client server application in vb6?
give one example
Sunday, April 29, 2007 6:07 PM -
You can create a client server app in VB.
If you have msdn just search for the help of Winsock. Its a control. Use it.
If you cant find it, let me know ill post an example.Sunday, April 29, 2007 6:55 PM -
I don't have MSDN friend
So can u post the code for me.
Tuesday, May 1, 2007 6:26 PM -
Does u know about timer control
the timer control is used for performing operations with in a seconds of time.
It is also helpful for animating the forms or texts
Tuesday, May 1, 2007 6:30 PM -
Deepak_Sharma_1d9447 wrote: I don't have MSDN friend
So can u post the code for me.
Hereis a detailed description about the windsock control as well as the steps of how to create a sample app.. with code example
----------------------
Using the Winsock Control
A WinSock control allows you to connect to a remote machine and exchange data using either the User Datagram Protocol (UDP) or the Transmission Control Protocol (TCP). Both protocols can be used to create client and server applications. Like the Timer control, the WinSock control doesn't have a visible interface at run time.
Possible Uses
- Create a client application that collects user information before sending it to a central server.
- Create a server application that functions as a central collection point for data from several users.
- Create a "chat" application.
Selecting a Protocol
When using the WinSock control, the first consideration is whether to use the TCP or the UDP protocol. The major difference between the two lies in their connection state:
- The TCP protocol control is a connection-based protocol, and is analogous to a telephone — the user must establish a connection before proceeding.
- The UDP protocol is a connectionless protocol, and the transaction between two computers is like passing a note: a message is sent from one computer to another, but there is no explicit connection between the two. Additionally, the maximum data size of individual sends is determined by the network.
The nature of the application you are creating will generally determine which protocol you select. Here are a few questions that may help you select the appropriate protocol:
- Will the application require acknowledgment from the server or client when data is sent or received? If so, the TCP protocol requires an explicit connection before sending or receiving data.
- Will the data be extremely large (such as image or sound files)? Once a connection has been made, the TCP protocol maintains the connection and ensures the integrity of the data. This connection, however, uses more computing resources, making it more "expensive."
- Will the data be sent intermittently, or in one session? For example, if you are creating an application that notifies specific computers when certain tasks have completed, the UDP protocol may be more appropriate. The UDP protocol is also more suited for sending small amounts of data.
Setting the Protocol
To set the protocol that your application will use: at design-time, on the Properties window, click Protocol and select either sckTCPProtocol, or sckUDPProtocol. You can also set the Protocol property in code, as shown below:
Winsock1.Protocol = sckTCPProtocol
Determining the Name of Your Computer
To connect to a remote computer, you must know either its IP address or its "friendly name." The IP address is a series of three digit numbers separated by periods (xxx.xxx.xxx.xxx). In general, it's much easier to remember the friendly name of a computer.
To find your computer's name
- On the Taskbar of your computer, click Start.
- On the Settings item, click the Control Panel.
- Double-click the Network icon.
- Click the Identification tab.
- The name of your computer will be found in the Computer name box.
Once you have found your computer's name, it can be used as a value for the RemoteHost property.
TCP Connection Basics
When creating an application that uses the TCP protocol, you must first decide if your application will be a server or a client. Creating a server means that your application will "listen," on a designated port. When the client makes a connection request, the server can then accept the request and thereby complete the connection. Once the connection is complete, the client and server can freely communicate with each other.
The following steps create a rudimentary server:
To create a TCP server
- Create a new Standard EXE project.
- Change the name of the default form to frmServer.
- Change the caption of the form to "TCP Server."
- Draw a Winsock control on the form and change its name to tcpServer.
- Add two TextBox controls to the form. Name the first txtSendData, and the second txtOutput.
- Add the code below to the form.
Private Sub Form_Load()
' Set the LocalPort property to an integer.
' Then invoke the Listen method.
tcpServer.LocalPort = 1001
tcpServer.Listen
frmClient.Show ' Show the client form.
End Sub
Private Sub tcpServer_ConnectionRequest _
(ByVal requestID As Long)
' Check if the control's State is closed. If not,
' close the connection before accepting the new
' connection.
If tcpServer.State <> sckClosed Then _
tcpServer.Close
' Accept the request with the requestID
' parameter.
tcpServer.Accept requestID
End Sub
Private Sub txtSendData_Change()
' The TextBox control named txtSendData
' contains the data to be sent. Whenever the user
' types into the textbox, the string is sent
' using the SendData method.
tcpServer.SendData txtSendData.Text
End Sub
Private Sub tcpServer_DataArrival _
(ByVal bytesTotal As Long)
' Declare a variable for the incoming data.
' Invoke the GetData method and set the Text
' property of a TextBox named txtOutput to
' the data.
Dim strData As String
tcpServer.GetData strData
txtOutput.Text = strData
End Sub
The procedures above create a simple server application. However, to complete the scenario, you must also create a client application.
To create a TCP client
- Add a new form to the project, and name it frmClient.
- Change the caption of the form to TCP Client.
- Add a Winsock control to the form and name it tcpClient.
- Add two TextBox controls to frmClient. Name the first txtSend, and the second txtOutput.
- Draw a CommandButton control on the form and name it cmdConnect.
- Change the caption of the CommandButton control to Connect.
- Add the code below to the form.
Important Be sure to change the value of the RemoteHost property to the friendly name of your computer.
Private Sub Form_Load()
' The name of the Winsock control is tcpClient.
' Note: to specify a remote host, you can use
' either the IP address (ex: "121.111.1.1") or
' the computer's "friendly" name, as shown here.
tcpClient.RemoteHost = "RemoteComputerName"
tcpClient.RemotePort = 1001
End Sub
Private Sub cmdConnect_Click()
' Invoke the Connect method to initiate a
' connection.
tcpClient.Connect
End Sub
Private Sub txtSendData_Change()
tcpClient.SendData txtSend.Text
End Sub
Private Sub tcpClient_DataArrival _
(ByVal bytesTotal As Long)
Dim strData As String
tcpClient.GetData strData
txtOutput.Text = strData
End SubThe code above creates a simple client-server application. To try the two together, run the project, and click Connect. Then type text into the txtSendData TextBox on either form, and the same text will appear in the txtOutput TextBox on the other form.
Accepting More than One Connection Request
The basic server outlined above accepts only one connection request. However, it is possible to accept several connection requests using the same control by creating a control array. In that case, you do not need to close the connection, but simply create a new instance of the control (by setting its Index property), and invoking the Accept method on the new instance.
The code below assumes there is a Winsock control on a form named sckServer, and that its Index property has been set to 0; thus the control is part of a control array. In the Declarations section, a module-level variable intMax is declared. In the form's Load event, intMax is set to 0, and the LocalPort property for the first control in the array is set to 1001. Then the Listen method is invoked on the control, making it the "listening control. As each connection request arrives, the code tests to see if the Index is 0 (the value of the "listening" control). If so, the listening control increments intMax, and uses that number to create a new control instance. The new control instance is then used to accept the connection request.
Private intMax As Long
Private Sub Form_Load()
intMax = 0
sckServer(0).LocalPort = 1001
sckServer(0).Listen
End Sub
Private Sub sckServer_ConnectionRequest _
(Index As Integer, ByVal requestID As Long)
If Index = 0 Then
intMax = intMax + 1
Load sckServer(intMax)
sckServer(intMax).LocalPort = 0
sckServer(intMax).Accept requestID
Load txtData(intMax)
End If
End SubUDP Basics
Creating a UDP application is even simpler than creating a TCP application because the UDP protocol doesn't require an explicit connection. In the TCP application above, one Winsock control must explicitly be set to "listen," while the other must initiate a connection with the Connect method.
In contrast, the UDP protocol doesn't require an explicit connection. To send data between two controls, three steps must be completed (on both sides of the connection):
- Set the RemoteHost property to the name of the other computer.
- Set the RemotePort property to the LocalPort property of the second control.
- Invoke the Bind method specifying the LocalPort to be used. (This method is discussed in greater detail below.)
Because both computers can be considered "equal" in the relationship, it could be called a peer-to-peer application. To demonstrate this, the code below creates a "chat" application that allows two people to "talk" in real time to each other:
To create a UDP Peer
- Create a new Standard EXE project.
- Change the name of the default form to frmPeerA.
- Change the caption of the form to "Peer A."
- Draw a Winsock control on the form and name it udpPeerA.
- On the Properties page, click Protocol and change the protocol to UDPProtocol.
- Add two TextBox controls to the form. Name the first txtSend, and the second txtOutput.
- Add the code below to the form.
Private Sub Form_Load()
' The control's name is udpPeerA
With udpPeerA
' IMPORTANT: be sure to change the RemoteHost
' value to the name of your computer.
.RemoteHost= "PeerB"
.RemotePort = 1001 ' Port to connect to.
.Bind 1002 ' Bind to the local port.
End With
frmPeerB.Show ' Show the second form.
End Sub
Private Sub txtSend_Change()
' Send text as soon as it's typed.
udpPeerA.SendData txtSend.Text
End Sub
Private Sub udpPeerA_DataArrival _
(ByVal bytesTotal As Long)
Dim strData As String
udpPeerA.GetData strData
txtOutput.Text = strData
End Sub
To create a second UDP Peer
- Add a standard form to the project.
- Change the name of the form to frmPeerB.
- Change the caption of the form to "Peer B."
- Draw a Winsock control on the form and name it udpPeerB.
- On the Properties page, click Protocol and change the protocol to UDPProtocol.
- Add two TextBox controls to the form. Name the TextBox txtSend, and the second txtOutput.
- Add the code below to the form.
Private Sub Form_Load()
' The control's name is udpPeerB.
With udpPeerB
' IMPORTANT: be sure to change the RemoteHost
' value to the name of your computer.
.RemoteHost= "PeerA"
.RemotePort = 1002 ' Port to connect to.
.Bind 1001 ' Bind to the local port.
End With
End Sub
Private Sub txtSend_Change()
' Send text as soon as it's typed.
udpPeerB.SendData txtSend.Text
End Sub
Private Sub udpPeerB_DataArrival _
(ByVal bytesTotal As Long)
Dim strData As String
udpPeerB.GetData strData
txtOutput.Text = strData
End Sub
To try the example, press F5 to run the project, and type into the txtSend TextBox on either form. The text you type will appear in the txtOutput TextBox on the other form.
About the Bind Method
As shown in the code above, you must invoke the Bind method when creating a UDP application. The Bind method "reserves" a local port for use by the control. For example, when you bind the control to port number 1001, no other application can use that port to "listen" on. This may come in useful if you wish to prevent another application from using that port.
The Bind method also features an optional second argument. If there is more than one network adapter present on the machine, the LocalIP argument allows you to specify which adapter to use. If you omit the argument, the control uses the first network adapter listed in the Network control panel dialog box of the computer's Control Panel Settings.
When using the UDP protocol, you can freely switch the RemoteHost and RemotePort properties while remaining bound to the same LocalPort. However, with the TCP protocol, you must close the connection before changing the RemoteHost and RemotePort properties.
Wednesday, May 2, 2007 4:19 AM - Create a client application that collects user information before sending it to a central server.
-
One question asked in interview
--how many maximum number of controls can be put on a single form?
any replies!!!!!
Saturday, May 5, 2007 7:18 PM -
I think the answer should be WITH CONFIDENCE "As many as we could, as long as the ram dont get full , if ram gets full, OS will do swapping and paging "
One key thing in interview that matters is confidence, it dont matter if you are giving wrong or right, but your answer should be to the topic, and should feel that you attempted.
This is what i feel, Others can give their options.Sunday, May 6, 2007 4:59 AM -
Hey Harshil thanx for ur input
But the queestion was in written exam with options
a)10
b) 20
c) 100
d) as many as form size
Monday, May 7, 2007 6:32 PM -
@deepak - The obvious answer would be (d)Tuesday, May 8, 2007 4:06 AM
-
you are wrong harshil. you can have max 255 controls on a form at a given time.Tuesday, May 8, 2007 9:02 AM
-
Ohh sorry m8, I got confused with the options that was provided in the questions
Thanks for correcting me, and informing the right answeryou rox sanket.
Tuesday, May 8, 2007 9:04 AM -
thanks harshil.Tuesday, May 8, 2007 9:07 AM
-
Jet DB Operations
DeclarationsJust paste it in your .bas/modules
Modules = .Bas File
The object type is a database object dao/ado database
============
For DAO
dim wkData as dao.workspace
Dim dbData as dao.Database
============
For ADo
din cnn as new connection
*Sample
OpenDatabaseWithPassWord(dbData, "Test.mdb", "vbcode")
OpenConnectionWithPassWord(cnn,"Provider=Microsoft.Jet.OLEDB.4.0;","Data Source=" + app.path + "\"+ "Test.mdb","vbcode")
Jet DB Operations
CodeOption Explicit
'* Open the Database Password in DAO
Sub OpendatabaseWithPassword(DB As Object, strDatabase As String, strPass As String)
Set DB = DBEngine.OpenDatabase(App.Path & "\" & strDatabase, False, False, ";pwd=" & strPass)
End Sub
'* Open Database Password in ADO
Sub OpenConnectionWithPassword(DB As Object, strProvider, strDataSource As String, strPassWord As String)
DB.Open _
strProvider & _
strDataSource & _
strPassWord
End Sub
'* Change The Database Password in DAO
Sub ChangeDBPassword_DAO(DB As Object, strDatabase As String, strOldPass As String, strNewPass As String)
Set DB = DBEngine.OpenDatabase(App.Path & "\" & strDatabase, True, False, ";pwd=" & strOldPass)
DB.NewPassword strOldPass, strNewPass
DB.Close
End Sub
'* Change The User-Level Password in DAO
Sub ChangeUserPassword_DAO(DB As Object, strOldPass As String, strNewPass As String)
DBEngine.SystemDB = "c:\win98\system\system.mdw"
Set DB = DBEngine.CreateWorkspace("", "Admin", strOldPass)
DB.Users("Admin").NewPassword strOldPass, strNewPass
DB.Close
End Sub
'* Change The User-Level Password in ADO
'* Assumes that the Admin user doesn't currently have a password set
'* Provider=Microsoft.Jet.OLEDB.4.0;
Sub ChangeUserPassword_ADO(DB As Object, strProvider, strDataSource As String, strSystem As String, strOldPassword As String, strNewPassword As String)
DB.ActiveConnection = _
strProvider & _
strDataSource & _
strSystem
DB.Users("Admin").ChangePassword strOldPassword, strNewPassword
Set DB = Nothing
End Sub
'* Add The New User Group and Password in DAO
Sub CreateUserGroup_DAO(DB As Object, User As Object, NewUser As String, strPID As String, strPassWord As String, wrkPass As String)
DBEngine.SystemDB = "c:\win98\system\system.mdw"
Set DB = DBEngine.CreateWorkspace("", "Admin", wrkPass)
Set User = DB.CreateUser(NewUser, strPID, strPassWord)
DB.Users.Append User
DB.Close
End Sub
'* Add The New User To Group
Sub AddUserToGroup(DB As Object, strPass As String, strNewUser As String, strNewGroup)
DBEngine.SystemDB = "c:\win98\system\system.mdw"
Set DB = DBEngine.CreateWorkspace("", "Admin", strPass)
DB.Users(strNewUser).Groups.Append _
DB.Users(strNewUser).CreateGroup(strNewGroup)
DB.Close
End SubTuesday, May 8, 2007 9:12 AM -
Wow new VB codes
i just love it. You are doing a great job sanket
keepit up.
Tuesday, May 8, 2007 9:19 AM -
Hey friends,
I'm dumping this thread as it has started giving troubles. Please check out the part 2 of this thread and start posting there.Tuesday, May 8, 2007 9:20 AM