VB Tips & Tricks

**sashi** · Dec 2 '06, 05:05 PM

Connection string More samples

MsAccess - Connection String

Standard security

Code:

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Data Source=c:\somepath\myDb.mdb;"

If using a Workgroup (System Database)

Code:

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Data Source=c:\somepath\mydb.mdb;" & _ 
           "Jet OLEDB:System Database=MySystem.mdw", _
           "myUsername", "myPassword"

If MDB has a database password

Code:

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Data Source=c:\somepath\mydb.mdb;" & _ 
           "Jet OLEDB:Database Password=MyDbPassword", _
           "myUsername", "myPassword"

If want to open up the MDB exclusively

Code:

oConn.Mode = adModeShareExclusive
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Data Source=c:\somepath\myDb.mdb;"

If MDB is located on a network share

Code:

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Data Source=\\myServer\myShare\myPath\myDb.mdb"

ODBC - Open Database Connectivity

DSN

Code:

oConn.Open "DSN=mySystemDSN;" & _ 
           "Uid=myUsername;" & _ 
           "Pwd=myPassword"

File DSN

Code:

oConn.Open "FILEDSN=c:\somepath\mydb.dsn;" & _ 
           "Uid=myUsername;" & _
           "Pwd=myPassword"

MsSQL Server - Connection String

For Standard Security

Code:

oConn.Open "Provider=sqloledb;" & _ 
           "Data Source=myServerName;" & _
           "Initial Catalog=myDatabaseName;" & _
           "User Id=myUsername;" & _
           "Password=myPassword"

OR

Code:

oConn.Open "Provider=sqloledb;" & _ 
           "Server=myServerName;" & _
           "Database=myDatabaseName;" & _
           "User Id=myUsername;" & _
           "Password=myPassword"

For a Trusted Connection

Code:

oConn.Open "Provider=sqloledb;" & _
           "Data Source=myServerName;" & _
           "Initial Catalog=myDatabaseName;" & _
           "Integrated Security=SSPI"

To connect to a "Named Instance"

Code:

oConn.Open "Provider=sqloledb;" & _
           "Data Source=myServerName\myInstanceName;" & _
           "Initial Catalog=myDatabaseName;" & _
           "User Id=myUsername;" & _
           "Password=myPassword"

Note: In order to connect to a SQL Server 2000 "named instance", you must have MDAC 2.6 (or greater) installed.

To Prompt user for username and password

Code:

oConn.Provider = "sqloledb"
oConn.Properties("Prompt") = adPromptAlways
oConn.Open "Data Source=myServerName;" & _
           "Initial Catalog=myDatabaseName"

To connect to SQL Server running on the same computer

Code:

oConn.Open "Provider=sqloledb;" & _
           "Data Source=(local);" & _
           "Initial Catalog=myDatabaseName;" & _
           "User ID=myUsername;" & _
           "Password=myPassword"

To connect to SQL Server running on a remote computer (via an IP address)

Code:

oConn.Open "Provider=sqloledb;" & _
           "Network Library=DBMSSOCN;" & _
           "Data Source=xxx.xxx.xxx.xxx,1433;" & _
           "Initial Catalog=myDatabaseName;" & _
           "User ID=myUsername;" & _
           "Password=myPassword"

**sashi** · Dec 4 '06, 09:53 AM

Format database date

Code:

Public Function FormatDate(ByVal vdtDate As Date) As String
Dim dtNullDate As Date
FormatDate = "NULL"

  If vdtDate = dtNullDate Then Exit Function
  If DatePart("h", vdtDate) = 0 And DatePart("n", vdtDate) = 0 And     DatePart("s", vdtDate) = 0 Then
    FormatDate = "{d '" & Format$(vdtDate, "yyyy-mm-dd") & "'}"
  Else
    FormatDate = "{ts '" & Format$(vdtDate, "yyyy-mm-dd hh:nn:ss") & "'}"
  End If
End Function

**sashi** · Dec 4 '06, 09:56 AM

Apostrophe

Have you ever tried to send a string variable to MS Access that had apostrophes embedded within an SQL Statement? If YES you will get a run time ERROR. Here is your solution, a function that formats the variable before sending it to the database.

Code:

Public Function Apostrophe(sFieldString As String) As String
  If InStr(sFieldString, "'") Then
    Dim iLen As Integer
    Dim ii As Integer
    Dim apostr As Integer
    iLen = Len(sFieldString)
    ii = 1

      Do While ii <= iLen
        If Mid(sFieldString, ii, 1) = "'" Then
          apostr = ii
          sFieldString = Left(sFieldString, apostr) & "'" & _
          Right(sFieldString, iLen - apostr)
          iLen = Len(sFieldString)
          ii = ii + 1
        End If
      ii = ii + 1
      Loop
  End If

  Apostrophe = sFieldString
End Function

**sashi** · Dec 4 '06, 02:52 PM

ShellExecute

Code:

'Module code - modShellExecute

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'vbHide = 0
'vbNormalFocus = 1
'vbMinimizedFocus = 2
'vbMaximizedFocus = 3
'vbNormalNoFocus = 4
'vbMinimizedNoFocus = 6

Public Enum vbWindowsState
    Hide = 0
    NormalFocus = 1
    MinimizedFocus = 2
    MaximizedFocus = 3
    NormalNoFocus = 4
    MinimizedNoFocus = 6
End Enum

Public Function OpenApplication(ByVal strOperation As String, _
                                ByVal strApplicationName As String, _
                                ByVal strParameter As String, _
                                ByVal strApplicationDirectory As String, _
                                ByVal WindowsState As vbWindowsState) As Boolean

Dim nWindowsState As Integer
    
    Select Case WindowsState
        Case 0
            nWindowsState = vbHide
        Case 1
            nWindowsState = vbNormalFocus
        Case 2
            nWindowsState = vbMinimizedFocus
        Case 3
            nWindowsState = vbMaximizedFocus
        Case 4
            nWindowsState = vbNormalNoFocus
        Case 6
            nWindowsState = vbMinimizedNoFocus
    End Select
    
    ShellExecute 0&, strOperation, strApplicationName, strParameter, strApplicationDirectory, WindowsState
End Function

'Form code - frmShellExecute

Private Sub cmdShellExecute_Click()
    modShellExecute.OpenApplication vbNullString, "The Application", vbNullString, vbNullString, MaximizedFocus
End Sub

**sashi** · Dec 4 '06, 02:53 PM

Shut down Windows

Code:

'Module code - modShutdown

' Shutdown Flags
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const SE_PRIVILEGE_ENABLED = &H2
Const TokenPrivileges = 3
Const TOKEN_ASSIGN_PRIMARY = &H1
Const TOKEN_DUPLICATE = &H2
Const TOKEN_IMPERSONATE = &H4
Const TOKEN_QUERY = &H8
Const TOKEN_QUERY_SOURCE = &H10
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_ADJUST_GROUPS = &H40
Const TOKEN_ADJUST_DEFAULT = &H80
Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Const ANYSIZE_ARRAY = 1
Private Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type
Private Type Luid
    lowpart As Long
    highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
    'pLuid As Luid
    pLuid As LARGE_INTEGER
    Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Private Declare Function InitiateSystemShutdown Lib "advapi32.dll" Alias "InitiateSystemShutdownA" (ByVal lpMachineName As String, ByVal lpMessage As String, ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LARGE_INTEGER) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Public Function InitiateShutdown(ByVal Machine As String, _
                                 Optional Force As Variant, _
                                 Optional Restart As Variant, _
                                 Optional AllowLocalShutdown As Variant, _
                                 Optional Delay As Variant, _
                                 Optional Message As Variant) As Boolean

    Dim hProc As Long
    Dim OldTokenStuff As TOKEN_PRIVILEGES
    Dim OldTokenStuffLen As Long
    Dim NewTokenStuff As TOKEN_PRIVILEGES
    Dim NewTokenStuffLen As Long
    Dim pSize As Long
    If IsMissing(Force) Then Force = False
    If IsMissing(Restart) Then Restart = True
    If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown = False
    If IsMissing(Delay) Then Delay = 0
    If IsMissing(Message) Then Message = ""
    'Make sure the Machine-name doesn't start with '\\'
    If InStr(Machine, "\\") = 1 Then
        Machine = Right(Machine, Len(Machine) - 2)
    End If
    'check if it's the local machine that's going to be shutdown
    If (LCase(GetMachineName) = LCase(Machine)) Then
        'may we shut this computer down?
        If AllowLocalShutdown = False Then Exit Function
        'open access token
        If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hProc) = 0 Then
            MsgBox "OpenProcessToken Error: " & GetLastError()
            Exit Function
        End If
        'retrieve the locally unique identifier to represent the Shutdown-privilege name
        If LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, OldTokenStuff.Privileges(0).pLuid) = 0 Then
            MsgBox "LookupPrivilegeValue Error: " & GetLastError()
            Exit Function
        End If
        NewTokenStuff = OldTokenStuff
        NewTokenStuff.PrivilegeCount = 1
        NewTokenStuff.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
        NewTokenStuffLen = Len(NewTokenStuff)
        pSize = Len(NewTokenStuff)
        'Enable shutdown-privilege
        If AdjustTokenPrivileges(hProc, False, NewTokenStuff, NewTokenStuffLen, OldTokenStuff, OldTokenStuffLen) = 0 Then
            MsgBox "AdjustTokenPrivileges Error: " & GetLastError()
            Exit Function
        End If
        'initiate the system shutdown
        If InitiateSystemShutdown("\\" & Machine, Message, Delay, Force, Restart) = 0 Then
            Exit Function
        End If
        NewTokenStuff.Privileges(0).Attributes = 0
        'Disable shutdown-privilege
        If AdjustTokenPrivileges(hProc, False, NewTokenStuff, Len(NewTokenStuff), OldTokenStuff, Len(OldTokenStuff)) = 0 Then
            Exit Function
        End If
    Else
        'initiate the system shutdown
        If InitiateSystemShutdown("\\" & Machine, Message, Delay, Force, Restart) = 0 Then
            Exit Function
        End If
    End If
    InitiateShutdown = True
End Function

Function GetMachineName() As String
    Dim sLen As Long
    'create a buffer
    GetMachineName = Space(100)
    sLen = 100
    'retrieve the computer name
    If GetComputerName(GetMachineName, sLen) Then
        GetMachineName = Left(GetMachineName, sLen)
    End If
End Function


'Form code - frmShutdown

Private Sub cmdShutdownNow_Click()
    modShutdown.InitiateShutdown GetMachineName, True, False, True, 60, "Message to state reason for shutdown!"
End Sub

**sashi** · Dec 4 '06, 02:54 PM

Generate Random Password

Code:

'Form code - frmPasswordGenerate

Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Function PassGen(nLen As Integer)
Dim range As Collection
Dim ivalue, icount, iLen As Long
Dim pass As String

    Set range = New Collection
    range.Add ("0")
    range.Add ("1")
    range.Add ("2")
    range.Add ("3")
    range.Add ("4")
    range.Add ("5")
    range.Add ("6")
    range.Add ("7")
    range.Add ("8")
    range.Add ("9")
 
    icount = 0
    ivalue = 0
    iLen = range.Count
    
    Do Until icount = nLen
      Randomize
      ivalue = CByte(Mid(CStr(Rnd(GetTickCount)), 3, 2))
       If ivalue > 0 And ivalue <= iLen Then
          icount = icount + 1
          pass = pass & range(ivalue)
       End If
    Loop
 
PassGen = pass
End Function

Private Sub cmdGeneratePassword_Click()
    MsgBox PassGen(8)
End Sub

**sashi** · Dec 4 '06, 02:55 PM

BLOB - Save image to database

Code:

Dim CN As New ADODB.Connection
Dim RS As ADODB.Recordset
Dim DataFile As Integer, Fl As Long, Chunks As Integer
Dim Fragment As Integer, Chunk() As Byte, i As Integer, FileName As String

Private Const ChunkSize As Integer = 16384
Private Const conChunkSize = 100

Private Sub cmdSave_Click()
    CN.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=Pubs;Data Source=Test"
    Dim strSQL As String

    strSQL = "SELECT * FROM pub_info where pub_id = '9999'"
    RS.Open strSQL, CN, adOpenForwardOnly, adLockOptimistic

    RS.AddNew
      SavePicture
    RS.Update

    Set RS = Nothing
    Set RS = New Recordset
End Sub

Private Sub SavePicture()
    Dim strFileNm As String
    DataFile = 1
    Open strFileNm For Binary Access Read As DataFile
        Fl = LOF(DataFile)   ' Length of data in file
        If Fl = 0 Then Close DataFile: Exit Sub
        Chunks = Fl \ ChunkSize
        Fragment = Fl Mod ChunkSize
        ReDim Chunk(Fragment)
        Get DataFile, , Chunk()
        RS!logo.AppendChunk Chunk()
        ReDim Chunk(ChunkSize)
        For i = 1 To Chunks
            Get DataFile, , Chunk()
            RS!logo.AppendChunk Chunk()
        Next i
    Close DataFile
End Sub

**sashi** · Dec 4 '06, 02:56 PM

BLOB - Retieve image stored in database

Code:

Dim CN As New ADODB.Connection
Dim RS As ADODB.Recordset
Dim DataFile As Integer, Fl As Long, Chunks As Integer
Dim Fragment As Integer, Chunk() As Byte, i As Integer, FileName As String

Private Const ChunkSize As Integer = 16384
Private Const conChunkSize = 100

Private Sub Form_Load()
    CN.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=Pubs;Data Source=Test"
    Dim strsql As String

    strsql = "SELECT * FROM pub_info where pub_id = '9999'"
    RS.Open strsql, CN, adOpenForwardOnly, adLockReadOnly
      ShowPic
    Set RS = Nothing
    Set RS = New Recordset
End Sub

Private Sub ShowPic()
    DataFile = 1
    Open "pictemp" For Binary Access Write As DataFile
        Fl = RS!logo.ActualSize ' Length of data in file
        If Fl = 0 Then Close DataFile: Exit Sub
        Chunks = Fl \ ChunkSize
        Fragment = Fl Mod ChunkSize
        ReDim Chunk(Fragment)
        Chunk() = RS!logo.GetChunk(Fragment)
        Put DataFile, , Chunk()
        For i = 1 To Chunks
            ReDim Buffer(ChunkSize)
            Chunk() = RS!logo.GetChunk(ChunkSize)
            Put DataFile, , Chunk()
        Next i
    Close DataFile
    FileName = "pictemp"
    Picture1.Picture = LoadPicture(FileName)
End Sub

**sashi** · Dec 5 '06, 05:57 AM

Disk free space

'Declarations

Code:

Option Explicit

Private Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As LARGE_INTEGER, lpTotalNumberOfBytes As LARGE_INTEGER, lpTotalNumberOfFreeBytes As LARGE_INTEGER) As Long

'Code

Code:

Public Function GetDiskSpace(sDrive As String) As String
    Dim lResult As Long
    Dim liAvailable As LARGE_INTEGER
    Dim liTotal As LARGE_INTEGER
    Dim liFree As LARGE_INTEGER
    Dim dblAvailable As Double
    Dim dblTotal As Double
    Dim dblFree As Double
    If Right(sDrive, 1) <> "" Then sDrive = sDrive & ""
    'Determine the Available Space, Total Size and Free Space of a drive
    lResult = GetDiskFreeSpaceEx(sDrive, liAvailable, liTotal, liFree)
   
    'Convert the return values from LARGE_INTEGER to doubles
    dblAvailable = CLargeInt(liAvailable.lowpart, liAvailable.highpart)
    dblTotal = CLargeInt(liTotal.lowpart, liTotal.highpart)
    dblFree = CLargeInt(liFree.lowpart, liFree.highpart)
   
    'Display the results
    GetDiskSpace = "Available Space on " & sDrive & ":  " & dblAvailable & " bytes (" & _
                Format(dblAvailable / 1024 ^ 3, "0.00") & " G) " & vbCr & _
                "Total Space on " & sDrive & ":      " & dblTotal & " bytes (" & _
                Format(dblTotal / 1024 ^ 3, "0.00") & " G) " & vbCr & _
                "Free Space on " & sDrive & ":       " & dblFree & " bytes (" & _
                Format(dblFree / 1024 ^ 3, "0.00") & " G) "
End Function

Private Function CLargeInt(Lo As Long, Hi As Long) As Double
    'This function converts the LARGE_INTEGER data type to a double
    Dim dblLo As Double, dblHi As Double
   
    If Lo < 0 Then
        dblLo = 2 ^ 32 + Lo
    Else
        dblLo = Lo
    End If
   
    If Hi < 0 Then
        dblHi = 2 ^ 32 + Hi
    Else
        dblHi = Hi
    End If
    CLargeInt = dblLo + dblHi * 2 ^ 32
End Function

**sashi** · Dec 5 '06, 08:30 AM

Set default printer

Windows API/Global Declarations

Code:

Public Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Public Const HWND_BROADCAST = &HFFFF&
    Public Const WM_WININICHANGE = &H1A

Code

Code:

Public Function SetDefaultPrinter(objPrn As Printer) As Boolean
    Dim x As Long, sztemp As String
    sztemp = objPrn.DeviceName & "," & objPrn.DriverName & "," & objPrn.Port
    x = WriteProfileString("windows", "device", sztemp)
    x = SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")
End Function

Private Sub Command1_Click()
    Dim x As Printer
    If MsgBox("Are You Sure Want To Set " & Combo1.Text & " as Default printer ? ", vbYesNo, "Attention") = vbYes Then

        For Each x In Printers
            If x.DeviceName = Combo1.Text Then
                SetDefaultPrinter x
                Exit Sub
            End If
        Next

    End If
End Sub

Private Sub Form_Load()
    Dim x As Printer
    Dim y As Integer
    y = 0

    With Combo1 'Scan all available printer and put them
        For Each x In Printers 'in To combo box.
            .AddItem x.DeviceName, y
            y = y + 1
        Next
        .ListIndex = 0
    End With

End Sub

**sashi** · Dec 6 '06, 04:48 AM

TabIndex

If your tabindex values are mixed up, I don't think VB6 gives you any convenient way to correct them - you have to edit them all (if I'm mistaken, I hope someone will point it out - I know MS Access has an option to sort them out).

The quickest way to do this is to start at the control you want to come last, then click on each of them in reverse sequence, and enter "0" for the TabIndex. You don't even have to hit enter, just click on the next one. So it's "0"-click-"0"-click-"0", very quick.

by Killer42

**sashi** · Dec 11 '06, 04:37 AM

Database connectiong string

DB_Connection_S tring.zip

**sashi** · Dec 11 '06, 04:38 AM

Windows system error lookup

Windows_System_ Error_Lookup.zi p

**sashi** · Dec 21 '06, 07:00 AM

Hints for Visual Basic & LPT-1

VB - LPT Programming

by adeebraza

VB Tips & Tricks

VB Tips & Tricks

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment