Visual Basic Tips & Tricks



Disable edit in ComboBox by code

Private Sub obj_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub
Log on file

Public Function LogOnFile(level As Integer, str As String) As Boolean
    Dim sLine As String
    Dim iFile As Integer
    Dim path As String
    Dim LOGLEVEL As Integer

    path = "prova.log"
    iFile = FreeFile
    Open path For Append Access Read Write Shared As iFile
        'Print #iFile, format$(Now, "dd/mm/yyyy") & " " & Time$ & " " & format$(err.Number, "00000") & " ";
        Print #iFile, Format$(Now, "dd/mm/yyyy") & " " & Time$ & " ";
        Print #iFile, Left$(str + Space$(100), 100)
    Close iFile

    If level = 0 Then
        MsgBox str
    End If
End Function
Get drive, paths, extensions,...

Public Function GetPath(PathFile As String) As String
   Dim i As Integer
   Dim j As Integer

   j = 1
   Do
      i = InStr(j, PathFile, "\")
      If i > 0 Then
         j = i + 1
      Else
         Exit Do
      End If
   Loop

   If j > 1 Then
      GetPath = Left(PathFile, j - 1)
   Else
      GetPath = "\"
   End If
End Function

Public Function GetDrive(PathFile As String) As String
   Dim i As Integer

   i = InStr(PathFile, "\")

   If i > 1 Then
      GetDrive = Left(PathFile, i - 1)
   Else
      GetDrive = ""
   End If
End Function

Public Function GetFile(PathFile As String) As String
   Dim i As Integer
   Dim j As Integer
   j = 1
   Do
      i = InStr(j, PathFile, "\")
      If i > 0 Then
         j = i + 1
      Else
         Exit Do
      End If
   Loop
   GetFile = Mid(PathFile, j)
End Function

Public Function GetExt(PathFile As String) As String
   Dim sFile As String
   Dim i As Integer
   sFile = GetFile(PathFile)
   i = InStr(sFile, ".")
   If i > 0 Then
      GetExt = Mid(sFile, i)
   End If
End Function

Public Function GetFileNoExt(PathFile As String) As String
   Dim i As Integer
   Dim sFile As String
   sFile = GetFile(PathFile)
   i = InStr(sFile, ".")
   If i > 0 Then
      GetFileNoExt = Left(sFile, i - 1)
   Else
      GetFileNoExt = sFile
   End If
End Function
Put in a ComboBox one field of a table

Public Function DbPutCombo(table As String, field As String, id As String, cmb As ComboBox) As Recordset
    Dim r As Recordset

    On Error Resume Next ' BEL 02.11.98
    Set r = gDatabase.OpenRecordset(table, dbOpenDynaset)
    r.MoveFirst
    Do While Not r.EOF
       cmb.AddItem r.fields(field).Value
       cmb.ItemData(cmb.ListCount - 1) = r.fields(id).Value
       r.MoveNext
    Loop
    Set DbPutCombo = r
End Function
Put in a ComboBox a file

Public Function FilePutCombo(path As String, cmb As ComboBox) As Integer
    Dim sLine As String
    Dim iFile As Integer
    Dim i As Integer

    i = 1
    iFile = FreeFile
    Open path For Input As iFile
    Do
        Line Input #iFile, sLine
        sLine = RTrim(sLine)
        If Left(sLine, 1) <> "#" Then
            cmb.AddItem sLine
            cmb.ItemData(cmb.ListCount - 1) = i
            i = i + 1
        End If
    Loop Until EOF(iFile)

    FilePutCombo = i - 1
    cmb.listindex = 0
    Close iFile
End Function
Round

'*----------------------------------------------------------*
'* Name       : Round                                       *
'*----------------------------------------------------------*
'* Purpose    : Rounds a decimal number to a specified      *
'*            : number of decimal places.                   *
'*----------------------------------------------------------*
'* Parameters : nValue  Required. Number to round.          *
'*            : nDigits Required. Number of decimal places. *
'*----------------------------------------------------------*
'* Returns    : Rounded value                               *
'*----------------------------------------------------------*
Public Function Round(nValue As Double, nDigits As Integer) As Double
    Round = Int(nValue * (10 ^ nDigits) + 0.5) / (10 ^ nDigits)
End Function
Byte Operations

Function LOWORD(ByVal dw As Long) As Integer
    If dw And &H8000& Then
        LOWORD = dw Or &HFFFF0000
    Else
        LOWORD = dw And &HFFFF&
    End If
End Function

Function LOBYTE(ByVal w As Integer) As Byte
    LOBYTE = w And &HFF
End Function

Function HIBYTE(ByVal w As Integer) As Byte
    HIBYTE = (w And &HFF00&) \ 256
End Function

 '*----------------------------------------------------------*
 '* Name       : MAKELONG                                    *
 '*----------------------------------------------------------*
 '* Purpose    : Combines two integers into a long integer.  *
 '*----------------------------------------------------------*
 '* Parameters : wLow   Required. Low WORD.                  *
 '*            : wHigh  Required. High WORD.                 *
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language MAKELONG macro.                    *
 '*----------------------------------------------------------*
 Public Function MAKELONG(wLow As Long, wHigh As Long) As Long
   MAKELONG = LOWORD(wLow) Or (&H10000 * LOWORD(wHigh))
 End Function

 '*----------------------------------------------------------*
 '* Name       : MAKELPARAM                                  *
 '*----------------------------------------------------------*
 '* Purpose    : Combines two integers into a long integer.  *
 '*----------------------------------------------------------*
 '* Parameters : wLow   Required. Low WORD.                  *
 '*            : wHigh  Required. High WORD.                 *
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language MAKELPARAM macro.                  *
 '*----------------------------------------------------------*
 Public Function MAKELPARAM(wLow As Long, wHigh As Long) As Long
   MAKELPARAM = MAKELONG(wLow, wHigh)
 End Function

 '*----------------------------------------------------------*
 '* Name       : MAKEWORD                                    *
 '*----------------------------------------------------------*
 '* Purpose    : Combines two integers into a 16-bit unsigned*
 '*            : integer (word).                             *
 '*----------------------------------------------------------*
 '* Parameters : wLow   Required. Low BYTE.                  *
 '*            : wHigh  Required. High BYTE.                 *
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language MAKELONG macro.                    *
 '*----------------------------------------------------------*
 Public Function MAKEWORD(wLow As Long, wHigh As Long) As Long
   MAKEWORD = LOBYTE(wLow) Or (&H100& * LOBYTE(wHigh))
 End Function

 '*----------------------------------------------------------*
 '* Name       : LOWORD                                      *
 '*----------------------------------------------------------*
 '* Purpose    : Returns the low 16-bit integer from a 32-bit*
 '*            : long integer.                               *
 '*----------------------------------------------------------*
 '* Parameters : dwValue Required. 32-bit long integer value.*
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language LOWORD macro.                      *
 '*----------------------------------------------------------*
 Public Function LOWORD1(dwValue As Long) As Integer
   MoveMemory LOWORD1, dwValue, 2
 End Function

 '*----------------------------------------------------------*
 '* Name       : HIWORD                                      *
 '*----------------------------------------------------------*
 '* Purpose    : Returns the high 16-bit integer from a      *
 '*            : 32-bit long integer.                        *
 '*----------------------------------------------------------*
 '* Parameters : dwValue Required. 32-bit long integer value.*
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language HIWORD macro.                      *
 '*----------------------------------------------------------*
 Public Function HIWORD1(dwValue As Long) As Integer
   MoveMemory HIWORD1, ByVal VarPtr(dwValue) + 2, 2
 End Function

 '*----------------------------------------------------------*
 '* Name       : LOBYTE                                      *
 '*----------------------------------------------------------*
 '* Purpose    : Returns the low 8-bit byte from a low word  *
 '*            : of 32-bit long integer.                     *
 '*----------------------------------------------------------*
 '* Parameters : dwValue Required. 32-bit long integer value.*
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language LOBYTE macro.                      *
 '*----------------------------------------------------------*
 Public Function LOBYTE1(dwValue As Long) As Byte
   MoveMemory LOBYTE1, LOWORD(dwValue), 1
 End Function

'*----------------------------------------------------------*
'* Name       : HIBYTE                                      *
'*----------------------------------------------------------*
'* Purpose    : Returns the high 8-bit byte from a low word *
'*            : of 32-bit long integer.                     *
'*----------------------------------------------------------*
'* Parameters : dwValue Required. 32-bit long integer value.*
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C'      *
'*            : language HIBYTE macro.                      *
'*----------------------------------------------------------*
Public Function HIBYTE1(dwValue As Long) As Byte
   MoveMemory HIBYTE1, ByVal VarPtr(LOWORD(dwValue)) + 1, 1
End Function

'*----------------------------------------------------------*
'* Name       : vbShiftLeft                                 *
'*----------------------------------------------------------*
'* Purpose    : Shift 32-bit integer value left 'n' bits.   *
'*----------------------------------------------------------*
'* Parameters : Value  Required. Value to shift.            *
'*            : Count  Required. Number of bit positions to *
'*            :        shift value.                         *
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C'      *
'*            : language construct '<<'.                    *
'*----------------------------------------------------------*
Public Function vbShiftLeft(ByVal Value As Long, _
                             Count As Integer) As Long
Dim i As Integer

   vbShiftLeft = Value

   For i = 1 To Count
     vbShiftLeft = vbShiftLeft * 2
   Next

End Function

'*----------------------------------------------------------*
 '* Name       : vbShiftRight                                *
 '*----------------------------------------------------------*
 '* Purpose    : Shift 32-bit integer value right 'n' bits.  *
 '*----------------------------------------------------------*
 '* Parameters : Value  Required. Value to shift.            *
 '*            : Count  Required. Number of bit positions to *
 '*            :        shift value.                         *
 '*----------------------------------------------------------*
 '* Description: This function is equivalent to the 'C'      *
 '*            : language construct '>>'.                    *
 '*----------------------------------------------------------*
 Public Function vbShiftRight(ByVal Value As Long, _
                              Count As Integer) As Long
 Dim i As Integer

   vbShiftRight = Value

   For i = 1 To Count
     vbShiftRight = vbShiftRight \ 2
   Next

 End Function
'*----------------------------------------------------------*
 '* Name       : BitSet                                      *
 '*----------------------------------------------------------*
 '* Purpose    : Sets a given Bit in Number                  *
 '*----------------------------------------------------------*
 Public Function BitSet(Number As Long, _
                        ByVal Bit As Long) As Long
   If Bit = 31 Then
     Number = &H80000000 Or Number
   Else
     Number = (2 ^ Bit) Or Number
   End If

   BitSet = Number
 End Function

 '*----------------------------------------------------------*
 '* Name       : BitClear                                    *
 '*----------------------------------------------------------*
 '* Purpose    : Clears a given Bit in Number                *
 '*----------------------------------------------------------*
 Public Function BitClear(Number As Long, _
                          ByVal Bit As Long) As Long
   If Bit = 31 Then
     Number = &H7FFFFFFF And Number
   Else
     Number = ((2 ^ Bit) Xor &HFFFFFFFF) And Number
   End If

   BitClear = Number
 End Function

 '*----------------------------------------------------------*
 '* Name       : BitIsSet                                    *
 '*----------------------------------------------------------*
 '* Purpose    : Test if bit 0 to bit 31 is set              *
 '*----------------------------------------------------------*
 Public Function BitIsSet(ByVal Number As Long, _
                          ByVal Bit As Long) As Boolean
   BitIsSet = False

   If Bit = 31 Then
     If Number And &H80000000 Then BitIsSet = True
   Else
     If Number And (2 ^ Bit) Then BitIsSet = True
   End If
 End Function
Spool a external file

'
' Win32 API Calls
'
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrn As Long, pDefault As Any) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrn As Long, ByVal level As Long, pDocInfo As DOC_INFO_1) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function WritePrinter Lib "winspool.drv" (ByVal hPrn As Long, pBuf As Any, ByVal cdBuf As Long, pcWritten As Long) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
'
' Structure required by StartDocPrinter
'
Private Type DOC_INFO_1
   pDocName As String
   pOutputFile As String
   pDatatype As String
End Type

Public Sub SpoolFile(sFile As String, PrnName As String, Optional AppName As String = "")
    Dim hPrn As Long
    Dim buffer() As Byte
    Dim hFile As Integer
    Dim Written As Long
    Dim di As DOC_INFO_1
    Dim i As Long
    Dim ret As Long
    Const BufSize As Long = &H4000

    On Error GoTo err1
    LogOnFile 1, "SpoolFile " & sFile & " on printer:" & PrnName

    '
    ' Extract filename from passed spec, and build job name.
    ' Fill remainder of DOC_INFO_1 structure.
    '
    If InStr(sFile, "\") Then
        For i = Len(sFile) To 1 Step -1
            If Mid(sFile, i, 1) = "\" Then Exit For
            di.pDocName = Mid(sFile, i, 1) & di.pDocName
        Next i
    Else
        di.pDocName = sFile
    End If
    If Len(AppName) Then
        di.pDocName = AppName & ": " & di.pDocName
    End If
    di.pOutputFile = vbNullString
    di.pDatatype = "RAW"
    '
    ' Open printer for output to obtain handle.
    ' Set it up to begin recieving raw data.
    '
    On Error Resume Next

    ret = OpenPrinter(PrnName, hPrn, vbNullString)
    If ret = 0 Then
        LogOnFile 0, "SpoolFile.Stampante:" & PrnName & " non riconosciuta (" & err.Number & "):" & err.Description
        Exit Sub
    End If
    ' informa lo spooler che un documento sara' stampato
    ' ritorna l'indicatore del job di stampa
    ret = StartDocPrinter(hPrn, 1, di)

    ' informa lo spooler di una pagina in stampa
    ret = StartPagePrinter(hPrn)

    On Error GoTo err_open
    '
    ' Open file and pump it to the printer.
    '
    hFile = FreeFile
    Open sFile For Binary Access Read As hFile
        '
        ' Read in 16K buffers and spool.
        '
        ReDim buffer(1 To BufSize) As Byte

        LogOnFile 1, "SpoolFile.len file:" & LOF(hFile)

        On Error GoTo err_rw
        For i = 1 To LOF(hFile) \ BufSize
            Get #hFile, , buffer
            ret = WritePrinter(hPrn, buffer(1), BufSize, Written)
        Next i
        '
        ' Get last chunk of file if it doesn't
        ' fit evenly into a 16K buffer.
        '
        If LOF(hFile) Mod BufSize Then
            ReDim buffer(1 To (LOF(hFile) Mod BufSize)) As Byte
            Get #hFile, , buffer
            ret = WritePrinter(hPrn, buffer(1), UBound(buffer), Written)
        End If
    Close #hFile

    On Error GoTo err3
    '
    ' Shut down spooling process.
    '
    ret = EndPagePrinter(hPrn)
    ret = EndDocPrinter(hPrn)
    ret = ClosePrinter(hPrn)
    Exit Sub

err1:
    LogOnFile 0, "SpoolFile.err1.spool(" & err.Number & "):" & err.Description
    Exit Sub

err_open:
    LogOnFile 0, "SpoolFile.err_open(" & sFile & ").spool(" & err.Number & "):" & err.Description
    Exit Sub

err_rw:
    LogOnFile 0, "SpoolFile.err_rw.spool(" & err.Number & "):" & err.Description
    Exit Sub

err3:
    LogOnFile 0, "SpoolFile.err3.spool(" & err.Number & "):" & err.Description
    Exit Sub
End Sub
Get User Name via API

 '*-------------------------------------------------------------*
 '* Name       : GetUserName                                    *
 '*-------------------------------------------------------------*
 '* Purpose    : Returns the current user name using a dll call *
 '*-------------------------------------------------------------*
 '* Description: Returns user name if found                     *
 '*-------------------------------------------------------------*
 Public Function GetUserName() As String
   Dim sBuffer As String
   Dim lSize As Long

   ' Space for dll parameters
   sBuffer = Space$(255)
   lSize = Len(sBuffer)

   Call GetUserNameAPI(sBuffer, lSize)

   If lSize > 0 Then
     ' Remove empty spaces
     GetUserName = Left$(sBuffer, lSize)
   Else
     ' Return empty if no user is found
     GetUserName = vbNullString
   End If
 End Function
...

...