locked
Forum for Helpful Visual Basic 6.0 Codes... RRS feed

  • 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 Smile  Wish this post a very good luck. Ill also try to post many codes, but after my exams Wink
    Thursday, April 19, 2007 9:54 AM

  • Various joy stick functions, determine if a joy stick is present

    Public 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



    Code

    Public 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 Function

    Thursday, April 19, 2007 9:59 AM
  • Thanks Harshil for supporting me, and also Best of Luck for your exams. Smile
    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 Function




    Thursday, April 19, 2007 10:02 AM

  • Code 3 : Makes a string appear on on the active form

    Print "I am cool --Sanket T. Shah."

    Thursday, April 19, 2007 10:04 AM

  • Code 4 : Makes a drawing application similar to paint

    Private 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 Sub

    Thursday, 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 Sub


    Thursday, April 19, 2007 10:08 AM

  • Code 6 : Just a fun thing to do

    Private 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 Sub

    Thursday, 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 = 100

    Thursday, 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 Sub


    Thursday, April 19, 2007 10:16 AM

  • Code 9 : Various registry routines
    Declarations

    Global 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 Function

    Thursday, April 19, 2007 10:36 AM
  • Code 10 : Create file association
    Declarations

    Option 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
    Code

    Public 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 Sub



    Thursday, 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 Smile

    This post has helped me a lot m8. Good work, keep it going. Vusy with exams atm Sad dont 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. Sad
    Thursday, April 19, 2007 4:49 PM

  • Code 11 : wrapper around the INIFile functions

    Option 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 Function



    Thursday, April 19, 2007 4:55 PM

  • Code 12 : Use TAPI32 to dial a telephone number
    Declarations

    Private 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
    Code

    Public 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 Sub

    Thursday, 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 Sub


    Thursday, 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 Function


    Thursday, April 19, 2007 5:06 PM

  • Code 15 : Export sql data to a CSV File

    Public 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 Function

    Thursday, April 19, 2007 5:10 PM
  • I hope its not a problem, if i post some queries also here Smile 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 Smile you are too good in explaining things Smile 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. Smile.

    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 Smile dont get much time for anything else, still i am trying hard to take up time for this forum Smile
    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 others Smile
    Monday, 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 Sub

    Monday, April 23, 2007 6:02 PM

  • Code 17 : Search all records with have the same category to other tables

    Private 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 Sub


    Monday, April 23, 2007 6:06 PM

  • Code 18 : SQL Statement, Select all Distinct Record on a Table and populate it on ComboBox or ListBox

    Private 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 Event

    Monday, 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 ADO
    Code:
    Public Function ColumnFormat(TableName As String, Column As Variant) 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)

        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 Sub



    Monday, 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 VB6

    Option 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 Sub


    Monday, 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 Sub


    Monday, 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 Sub


    Monday, April 23, 2007 6:34 PM

  • Code 24 : code for saving into a file what is in listbox

    Sub 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 Sub

    Monday, April 23, 2007 6:36 PM

  • Code 25 : Save ADO Recordset data in XML format file

    Private 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 Sub

    Monday, April 23, 2007 6:39 PM

  • Code 26 :  A easy way to get data from MSAccess parameter query into ADO Recordset

    Private 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 Sub

    Monday, 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 Function


    Monday, 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 Sub

    Monday, April 23, 2007 6:50 PM

  • Code 30 : Using ADO to open an Access MDB DSN-less

           Dim 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, adCmdText

    Monday, 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 Sub

    Monday, 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 Smile
    One doubt, what does KILL do ? Never came across such a statement in vb  Stick out tongue

    and btw, i am learning lot of new things that i didn't even knew, after you started this thread.  Smile
    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 ADO

    Public 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 Sub



    Tuesday, April 24, 2007 7:13 PM

  • Code 34 : Retrieving Access 97 password.
    Declarations

    Dim 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.
    Code

       mask = 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: " & lsClave




    Tuesday, April 24, 2007 7:17 PM

  • Code 35 : whenever Database has been modified check if it was and refreshes contents
    Declarations

    Public 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 Sub




    Tuesday, April 24, 2007 7:21 PM

  • Code 36 :  Extract the data from an ADO Recordset into a 2-D variant array

    Function 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 Function

    Tuesday, 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 SUPERP Smile
    Friday, April 27, 2007 12:34 PM

  • Jet DB Operations
    Declarations

    Just 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
    Code

    Option 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 Sub

    Tuesday, 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 Smile  Wish this post a very good luck. Ill also try to post many codes, but after my exams Wink
    Thursday, April 19, 2007 9:54 AM

  • Various joy stick functions, determine if a joy stick is present

    Public 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



    Code

    Public 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 Function

    Thursday, April 19, 2007 9:59 AM
  • Thanks Harshil for supporting me, and also Best of Luck for your exams. Smile
    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 Function




    Thursday, April 19, 2007 10:02 AM

  • Code 3 : Makes a string appear on on the active form

    Print "I am cool --Sanket T. Shah."

    Thursday, April 19, 2007 10:04 AM

  • Code 4 : Makes a drawing application similar to paint

    Private 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 Sub

    Thursday, 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 Sub


    Thursday, April 19, 2007 10:08 AM

  • Code 6 : Just a fun thing to do

    Private 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 Sub

    Thursday, 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 = 100

    Thursday, 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 Sub


    Thursday, April 19, 2007 10:16 AM

  • Code 9 : Various registry routines
    Declarations

    Global 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 Function

    Thursday, April 19, 2007 10:36 AM
  • Code 10 : Create file association
    Declarations

    Option 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
    Code

    Public 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 Sub



    Thursday, 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 Smile

    This post has helped me a lot m8. Good work, keep it going. Vusy with exams atm Sad dont 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. Sad
    Thursday, April 19, 2007 4:49 PM

  • Code 11 : wrapper around the INIFile functions

    Option 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 Function



    Thursday, April 19, 2007 4:55 PM

  • Code 12 : Use TAPI32 to dial a telephone number
    Declarations

    Private 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
    Code

    Public 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 Sub

    Thursday, 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 Sub


    Thursday, 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 Function


    Thursday, April 19, 2007 5:06 PM

  • Code 15 : Export sql data to a CSV File

    Public 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 Function

    Thursday, April 19, 2007 5:10 PM
  • I hope its not a problem, if i post some queries also here Smile 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 Smile you are too good in explaining things Smile 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. Smile.

    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 Smile dont get much time for anything else, still i am trying hard to take up time for this forum Smile
    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 others Smile
    Monday, 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 Sub

    Monday, April 23, 2007 6:02 PM

  • Code 17 : Search all records with have the same category to other tables

    Private 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 Sub


    Monday, April 23, 2007 6:06 PM

  • Code 18 : SQL Statement, Select all Distinct Record on a Table and populate it on ComboBox or ListBox

    Private 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 Event

    Monday, 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 ADO
    Code:
    Public Function ColumnFormat(TableName As String, Column As Variant) 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)

        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 Sub



    Monday, 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 VB6

    Option 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 Sub


    Monday, 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 Sub


    Monday, 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 Sub


    Monday, April 23, 2007 6:34 PM

  • Code 24 : code for saving into a file what is in listbox

    Sub 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 Sub

    Monday, April 23, 2007 6:36 PM

  • Code 25 : Save ADO Recordset data in XML format file

    Private 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 Sub

    Monday, April 23, 2007 6:39 PM

  • Code 26 :  A easy way to get data from MSAccess parameter query into ADO Recordset

    Private 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 Sub

    Monday, 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 Function


    Monday, 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 Sub

    Monday, April 23, 2007 6:50 PM

  • Code 30 : Using ADO to open an Access MDB DSN-less

           Dim 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, adCmdText

    Monday, 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 Sub

    Monday, 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 Smile
    One doubt, what does KILL do ? Never came across such a statement in vb  Stick out tongue

    and btw, i am learning lot of new things that i didn't even knew, after you started this thread.  Smile
    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 ADO

    Public 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 Sub



    Tuesday, April 24, 2007 7:13 PM

  • Code 34 : Retrieving Access 97 password.
    Declarations

    Dim 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.
    Code

       mask = 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: " & lsClave




    Tuesday, April 24, 2007 7:17 PM

  • Code 35 : whenever Database has been modified check if it was and refreshes contents
    Declarations

    Public 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 Sub




    Tuesday, April 24, 2007 7:21 PM

  • Code 36 :  Extract the data from an ADO Recordset into a 2-D variant array

    Function 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 Function

    Tuesday, 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 SUPERP Smile
    Friday, 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 Smile
    ----------------------

    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:

    1. 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.

    2. 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."

    3. 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

    1. On the Taskbar of your computer, click Start.

    2. On the Settings item, click the Control Panel.

    3. Double-click the Network icon.

    4. Click the Identification tab.

    5. 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

    1. Create a new Standard EXE project.

    2. Change the name of the default form to frmServer.

    3. Change the caption of the form to "TCP Server."

    4. Draw a Winsock control on the form and change its name to tcpServer.

    5. Add two TextBox controls to the form. Name the first txtSendData, and the second txtOutput.

    6. 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

    1. Add a new form to the project, and name it frmClient.

    2. Change the caption of the form to TCP Client.

    3. Add a Winsock control to the form and name it tcpClient.

    4. Add two TextBox controls to frmClient. Name the first txtSend, and the second txtOutput.

    5. Draw a CommandButton control on the form and name it cmdConnect.

    6. Change the caption of the CommandButton control to Connect.

    7. 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 Sub

    The 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 Sub

    UDP 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):

    1. Set the RemoteHost property to the name of the other computer.

    2. Set the RemotePort property to the LocalPort property of the second control.

    3. 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

    1. Create a new Standard EXE project.

    2. Change the name of the default form to frmPeerA.

    3. Change the caption of the form to "Peer A."

    4. Draw a Winsock control on the form and name it udpPeerA.

    5. On the Properties page, click Protocol and change the protocol to UDPProtocol.

    6. Add two TextBox controls to the form. Name the first txtSend, and the second txtOutput.

    7. 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

    1. Add a standard form to the project.

    2. Change the name of the form to frmPeerB.

    3. Change the caption of the form to "Peer B."

    4. Draw a Winsock control on the form and name it udpPeerB.

    5. On the Properties page, click Protocol and change the protocol to UDPProtocol.

    6. Add two TextBox controls to the form. Name the TextBox txtSend, and the second txtOutput.

    7. 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
  • 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 Smile

    Thanks for correcting me, and informing the right answer Smile you rox sanket.


    Tuesday, May 8, 2007 9:04 AM
  • thanks harshil. Smile
    Tuesday, May 8, 2007 9:07 AM

  • Jet DB Operations
    Declarations

    Just 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
    Code

    Option 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 Sub

    Tuesday, May 8, 2007 9:12 AM
  • Wow new VB codes Smile i just love it. You are doing a great job sanket Smile 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