VB Tips & Tricks

[sashi]

Hi everyone,

Here are some VB related tips & tricks, hope it helps. Good luck & Take care.

Important

This thread is closed for general posting. Please start a new thread if you have a question or comment.

ADMINISTRATOR

[sashi]

Connection string More samples

MsAccess - Connection String

Standard security

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

If using a Workgroup (System Database)

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

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

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

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

ODBC - Open Database Connectivity

DSN

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

File DSN

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

MsSQL Server - Connection String

For Standard Security

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

OR

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

For a Trusted Connection

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

To connect to a "Named Instance"

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

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

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)

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

[sashi]

Format database date

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]

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.

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]

ShellExecute

'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]

Shut down Windows

'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]

Generate Random Password

'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]

BLOB - Save image to database

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]

BLOB - Retieve image stored in database

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]

Disk free space

'Declarations

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

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]

Set default printer

Windows API/Global Declarations

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

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]

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]

Database connectiong string

DB_Connection_String.zip

[sashi]

Windows system error lookup

Windows_System_Error_Lookup.zip

[sashi]

Hints for Visual Basic & LPT-1

VB - LPT Programming

by adeebraza

[sashi]

PC's Parallel Port Details & Visual Basic programming

VB - Parallel port programming

by adeebraza

[sashi]

Know LPT-1 Visual Basic Driver for Win 2000 & XP

VB - WinXP LPT programming

by adeebraza

[Killer42]

Execute VB code from a string



In VB5 or VB6, to execute VB code from a string (for example, a textbox) add the Microsoft Script Control under Project | Components.

Here is some sample code which shows one way to make use of it...

Private Sub Form_Load()
  Text1.Text = "cmdText1.Visible = False"
  Call ScriptControl1.AddObject(cmdText1.Name, cmdText1)
End Sub
 
Private Sub Command1_Click()
  Call ScriptControl1.ExecuteStatement(Text1.Text)
End Sub

Further information is available by searching TheScripts or the entire web for “microsoft script control”.

By Steve Gerrard (guest) in Community > Newsgroup Archive > comp.lang.* > Visual Basic > How do I Execute the content of a textbox

Brought to the group’s attention by Phaneendra Varma