Here are some handy bits of code I've collected. Feel free to use and modify any of it.

Validate Age

This function checks a DOB against a validation age. Returns 'True' if the DOB is valid for the specified age. Returns 'False' if the DOB is not valid for the specified age.

Function FbCheckDOB(sTestDOB As String, iValidAge As Integer) As Boolean
   Dim lTemp As Long
   lTemp = DateDiff("d", CDate(sTestDOB), Now)
   If lTemp < (iValidAge * 365.25) Then
      FbCheckDOB = False
   Else
      FbCheckDOB = True
   End If
End Function

Odd or Even

This function determine whether a number is even or odd.

If passed a String:

Function FbIsEven(iTest As String) As Boolean
   Dim sTestValues As String, sTempChar As String, iAnswer As Integer
   sTestValues = "02468"
   sTempChar = Right$(Trim(Str$(iTest)), 1)
   iAnswer = InStr(1, sTestValues, sTempChar)
   FbIsEven = iAnswer
End Function

If passed an Integer:

Public Function IsEven(Number As Integer) As Boolean
    IsEven = ((Number Mod 2) = 0)
End Function

Faster Recordset Looping

If you perform some operation on every record of a Table or Recordset (eg to update certain fields or retrieve information), this code might be used:

Do Until MyDynaset.EOF
'...
   MyDynaset.MoveNext
Loop

However this variation is generally faster for larger recordsets because the EOF condition does not have to be with each iteration:

Dim k As Long, j As Long

MyDynaset.MoveLast
j = MyDynaset.RecordCount
MyDynaset.MoveFirst

For k = 1 to j
'...
   MyDynaset.MoveNext
Next

Reverse Letter Order

This function reverses strings, eg "Yoda" becomes "adoY".

Public Function FgsReverseName(sName as String)
   Dim iCount As Integer
   Dim sNew As String
   For iCount = 1 To Len(sName)
      strNew = Mid$(sName, iCountt, 1) & sNew
   Next
   FgsReverseName = sNew
End Sub

Tab if Max Characters Entered

Given a textbox, this code tabs to the next field when the maximum number of characters is reached:

Private Sub txtField_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
   If Len(txtField.Text) = txtField.MaxLength Then SendKeys "{TAB}"
End Sub

Tab if ENTER is Pressed

Given a textbox, this code converts the user's usage of ENTER into TAB:

Private Sub txtField_KeyPress(Index As Integer, KeyAscii As Integer)
   If KeyAscii = vbKeyReturn Or KeyAscii = vbKeySeparator Then
      SendKeys "{TAB}"
      KeyAscii = 0
   End If
End Sub

Programmatically Change Tab in TabStrip

This code will change the choice tab in a TabStrip.

Set frmTest.tabTest.SelectedItem = frmTest.tabTest.Tabs(1)

Refresh Data in DataGrid

This code will refresh a grid's data. It will retain the filter on the Data Environment Command. It will also retain the grid's formatting.

deData.rscmdCustomer.Requery
DoEvents
Set grdCustomers.DataSource = deData

Highlight Contents of Current Control

This sub will highlight the text in a textbox control. Without it, the cursor goes to the beginning of the text when focus shifts to the control. Call this sub from the control's GotFocus() event procedure.

Public Sub SgHighLight()
   If Screen.ActiveForm Is Nothing Then Exit Sub
   With Screen.ActiveForm
      If TypeOf .ActiveControl Is TextBox Then
        .ActiveControl.SelStart = 0
        .ActiveControl.SelLength = Len(.ActiveControl)
      End If
      DoEvents
   End With
End Sub

Escape the Unescaped

Takes an input string and converts any unescaped characters into escaped characters.

Public Function FgsSearchReplace(ByVal sStringToFix As String) As String
   Dim iPosition As Integer        '''Where is the offending char?
   Dim sCharToReplace As String    '''Which char do we want to replace?
   Dim sReplaceWith As String      '''What should it be replaced with?
   Dim sTempString As String       '''Build the correct returned string
   sCharToReplace = "'"
   sReplaceWith = "''"
   iPosition = InStr(sStringToFix, sCharToReplace)
   sTempString = ""
   Do While iPosition
     sTempString = sTempString & Left(sStringToFix, iPosition - 1)
     sTempString = sTempString & sReplaceWith
     sTempString = sTempString & _
       Mid(sStringToFix, iPosition + 1, Len(sStringToFix))
     iPosition = InStr(iPosition + 1, sStringToFix, sCharToReplace)
   Loop
   FgsSearchReplace = sTempString
End Function

Determine if Bookmark is Null

Given recordset, this function takes the current position and return either the bookmark or Null as appropriate.

Public Function FgvGetBookmark(ByRef rsX As ADODB.Recordset) As Variant
   Dim lngTotalRecords As Long
   With rsX
      lngTotalRecords = .RecordCount
      If (lngTotalRecords > 0) Then
         FgvGetBookmark = .Bookmark
      Else
         FgvGetBookmark = Null
      End If
   End With
End Function

Increment and Pad ID with Zeros

Given a recordset and a field name, this function returns a new ID padded with zeros.

Public Function FgsNewID(rsActual As ADODB.Recordset, sFieldName As String) As String
   Dim rsClone As ADODB.Recordset
   Set rsClone = rsActual.Clone
   With rsClone
      .Filter = adFilterNone
      .Sort = sFieldName
      .MoveLast
      FgsNewID = Right(String(.Fields(sFieldName).DefinedSize, "0") _
                     & Trim(Str(.Fields(sFieldName).Value + 1)), _
                     .Fields(sFieldName).DefinedSize)
      'i.e. take the greatest value, add one, pad with zeroes, then trim.
   End With
   Set rsClone = Nothing
End Function

Export Recordset to Excel

Given a recordset, this sub spits it out to an Excel spreadsheet, bolds the fields on top, and then closes the recordset.

Public Sub SgExportToExcel(ADORecordset As ADODB.Recordset)
   Dim objExcel As Object
   Dim objTemp As Object
   Dim iIndex As Integer
   Dim iRowIndex As Integer
   Dim iColIndex As Integer
   Dim iRecordCount As Integer
   Dim iFieldCount As Integer
   Dim sMessage As String
   Dim vRows As Variant
   Dim iExcelVersion As Integer
'Read all of the records into an array
   vRows = ADORecordset.GetRows()
 'Determine how many fields and records
   iFieldCount = UBound(vRows, 1) + 1
   iRecordCount = UBound(vRows, 2) + 1
 'Create reference variable for the spreadsheet
   Set objExcel = CreateObject("Excel.Application")
   objExcel.Visible = True
   objExcel.Workbooks.Add
 'Ensure that Excel remains visible if we switch to the Active Sheet
   Set objTemp = objExcel
 iExcelVersion = Val(objExcel.Application.Version)
   If iExcelVersion >= 8 Then
      Set objExcel = objExcel.ActiveSheet
   End If
 'Place the names of the fields in the column headers
   iRowIndex = 1
   iColIndex = 1
   For iColIndex = 1 To iFieldCount
      With objExcel.Cells(iRowIndex, iColIndex)
         .Value = ADORecordset.Fields(iColIndex - 1).Name
         With .Font
            .Name = "Arial"
            .Bold = True
            .Size = 9
         End With
      End With
   Next
 'Memory management
   ADORecordset.Close
   Set ADORecordset = Nothing
 'Just add data
   With objExcel
      For iRowIndex = 2 To iRecordCount + 1
         For iColIndex = 1 To iFieldCount
            .Cells(iRowIndex, iColIndex).Value = vRows _
               (iColIndex - 1, iRowIndex - 2)
         Next
      Next
   End With
   objExcel.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
End Sub

Convert Lowercase to UpperCase

Assures that all letters typed into a textbox are uppercase.

Private Sub txtShout_KeyPress(KeyAscii As Integer)
   KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Convert Alpha to Numeric

Converts letters into numbers on dial pad. Assumes txtFields(iFrom) is converted into txtFields(iFrom).

Public Sub SgLettersToNumbers(MyForm As Form, iFrom As Integer, iTo As Integer)
   Dim iDataLength As Integer
   Dim iDataPosition As Integer
   With MyForm
      .txtFields(iTo).Text = ""
      iDataLength = Len(.txtFields(iFrom).Text)
      If Len(.txtFields(iFrom).Text) > 0 Then
         With .txtFields(iTo)
            For iDataPosition = 1 To iDataLength
               Select Case Mid(MyForm.txtFields(iFrom).Text, iDataPosition, 1)
               Case "A", "B", "C"
                  .Text = .Text & "2"
               Case "D", "E", "F"
                  .Text = .Text & "3"
               Case "G", "H", "I"
                  .Text = .Text & "4"
               Case "J", "K", "L"
                  .Text = .Text & "5"
               Case "M", "N", "O"
                  .Text = .Text & "6"
               Case "P", "R", "S"
                  .Text = .Text & "7"
               Case "T", "U", "V"
                  .Text = .Text & "8"
               Case "W", "X", "Y"
                  .Text = .Text & "9"
               Case "Q", "Z"
                  .Text = .Text & "0"
               Case Else
                  .Text = .Text & Mid(MyForm.txtFields(iFrom).Text, iDataPosition, 1)
               End Select
            Next
         End With
      End If
   End With
End Sub

Ignore Punctuation Input

Ignores punctuation input in the Key Press event.

Private Sub cboFields_KeyPress(Index As Integer, KeyAscii As Integer)
   Select Case KeyAscii
   Case 48 To 57, 65 To 90 '0-9 and A-Z are OK       KeyAscii= KeyAscii
   Case 97 To 122 'a-z convert to CAPS
      KeyAscii= Asc(UCase(Chr(KeyAscii)))
   Case 32 To 47, 58 To 64, 91 To 96, 123 To 127 'Don't recognize punctuation       KeyAscii= 0
   End Select
End Sub

Generate PIN

Function returns a random 4-digit number, padded on the left with zeros.

Public Function FgsGeneratePIN() as Integer
   Randomize  'Initializes random-number generator.    FgsGeneratePIN = Right("0000" & CStr(Int((9999 * Rnd) + 1)), 4)
End Function

Detect SHIFT, CTRL, and ALT

You can determine what combination of SHIFT, CTRL, and ALT was pressed for a given key event using the following code (note that it will work for mouse events too).

Private Sub Text1_KeyDown(KeyCode As Integer, _
      Shift As Integer)
   Dim iShiftKey as Integer
   iShiftKey = Shift And 7
   Select Case iShiftKey
      Case 1 ' or vbShiftMask          Print "You pressed the SHIFT key."
      Case 2 ' or vbCtrlMask          Print "You pressed the CTRL key."
      Case 4 ' or vbAltMask          Print "You pressed the ALT key."
      Case 3
         Print "You pressed both SHIFT and CTRL."
      Case 5
         Print "You pressed both SHIFT and ALT."
      Case 6
         Print "You pressed both CTRL and ALT."
      Case 7
         Print "You pressed SHIFT, CTRL, and ALT."
      End Select
End Sub

Error Messages

Place the following subroutine in a module and have error handling routines access it to output a message for debugging.

Public Sub SgErrorMessage(sOther As String)
   MsgBox "Please write down the following for debugging:" & vbCrLf & _
          "Err.Number: " & Str(Err.Number) & ". " & _
          "Err.Source: " & Err.Source & ". " & _
          "Err.Description: " & Err.Description & ". " & _
          "Other: " & sOther & ".", _
          vbCritical, App.Title
End Sub

DataGrid Details

Use the following code to set properties for each column in a DataGrid.

Public Sub SFormatGrid
   Dim col As Column
'Set properties for entire grid here.
   grd.HeadFont.Bold = True
 'Set properties for each column with in Case.
   With col
      Select Case .DataField
      Case "Field1"
         .Caption = "Friendly Name for Field1"
         .Visible = True
         .Width = 2000
      Case Else
         .Visible = False
   End With
End Sub

Display GIF89s

Add the Microsoft Internet Controls component to your project. Doing so will add the WebBrowser control to your toolbox. Drop the control onto a form, then use either of the following chunks of code:

WebBrowser1.Navigate "PathOrURLToYourGIF89"
WebBrowser1.Navigate "about:<html><body scroll='no'>" & _
                     "<img src='URLToYourGIF89' />" & _
                     "</body></html>"

The second version gets rid of the scroll bars.

Wait Sub

This simple wait sub procedure pauses things for the number of milliseconds you indicate.

Add a Timer control to a form. Set its Name property to tmrWait. Set its Interval property to "0". Set its Enabled property to "False". Add the following procedure for the timer:

Private Sub tmrWait_Timer()
    tmrWait.Enabled = False
End Sub

Add the following subroutine to your form module to be called upon need:

Private Sub SWait(intMilliSeconds As Integer)
    tmrWait.Interval = intMilliSeconds
    tmrWait.Enabled = True
    Do While tmrWait.Enabled = True
        DoEvents
    Loop
End Sub

Convert Quotes to ASP Quotes

This will take a string and convert it to ASP ready VB or VBScript.

EG: This string

"<p class="x">

is returned as

Chr(34) & "<p class=" & Chr(34) & "x" & Chr(34)

Here is the code:

Private Function FstrASPQuote(PstrHTML As String) As String
  Dim lngPosHTML As Long 'Position in HTML
  Dim lngLenHTML As Long 'Length of HTML
  Dim lngPosASP As Long 'Position in ASP
  Dim lngLenASP As Long 'Length of ASP
  Dim lngPosHTMLFirst As Long 'Position of frist special character
  Dim lngPosHTMLNext As Long 'Position in HTML of next special character
  Dim lngLenHTMLNext As Long 'Length in HTML between special characters

  lngLenHTML = Len(PstrHTML)
  lngPosHTMLFirst = InStr(1, PstrHTML, Chr(34), vbTextCompare)

  'Not even one special character found
  If lngPosHTMLFirst = 0 Then
    FstrASPQuote = PstrHTML
    Exit Sub
  End If

  If lngPosHTMLFirst = 1 Then
    'A quote as the first character
    txtASP = "Chr(34)" & Left(PstrHTML, lngPosHTMLFirst - 1)
  Else
    'Up to the first special character
    txtASP = Chr(34) & Left(PstrHTML, lngPosHTMLFirst - 1) & Chr(34) & " & Chr(34)" 
  End If

  lngPosHTML = lngPosHTMLFirst + 1
  'Check if any left
  lngPosHTMLNext = InStr(lngPosHTML, PstrHTML, Chr(34), vbTextCompare)

  'Do while any left
  Do While lngPosHTMLNext <> 0
    lngLenHTMLNext = lngPosHTMLNext - lngPosHTML
    txtASP = txtASP & " & " & Chr(34) & Mid(PstrHTML, lngPosHTML, lngLenHTMLNext) & Chr(34) & " & Chr(34)"
    lngPosHTML = lngPosHTMLNext + 1
    lngPosHTMLNext = InStr(lngPosHTML, PstrHTML, Chr(34), vbTextCompare) 'Check if any left
  Loop

  If lngPosHTML < lngLenHTML Then
    txtASP = txtASP & " & " & Chr(34) & Mid(PstrHTML, lngPosHTML) & Chr(34)
  End If

  FstrASPQuote = txtASP
End Function

Pass ASP objects to a DLL

You can pass the ASP object to a dll and use them just as you would in an ASP page. 
Option Explicit
Dim rServer As Server
Dim rSession As Session
Dim rResponse As Response
Dim rRequest As Request
Dim strConnect As String
Dim pHooked As Boolean
Public Function SetHook(ByRef Rsp As Response, _
                        ByRef Req As Request, _
                        ByRef Srv As Server, _
                        ByRef Ses As Session)
On Error GoTo SetHook_Err
    Set rResponse = Rsp
    Set rServer = Srv
    Set rSession = Ses
    Set rRequest = Req
    pHooked = True
    Exit Function
SetHook_Err:
    pHooked = False
End Function

For a dll project that is has been passed the ASP objects, use code similar to the following. While developing, use the second Dim instead of the first to enable IntelliSense. When compiling the dll is ready to be used, use the first Dim instead of the second.

Dim obj1 As Object
'Dim obj1 As DLL.Class Set obj1 = CreateObject(DLL.Class)

Run some SQL code using ADO

To run some SQL code on SQL Server, try the following procedure:

  1. Check the sysobjects table to see if the object exists.
  2. Create the SQL statements that create the object.
  3. Run the Execute method on an appropriate ADO Connection object to execute the SQL statements just made.

EG:

strSQL = "SELECT * FROM sysobjects WHERE id = object_id" & _
         "('dbo.objX')"
rsX.Open strSQL, cnnX
If rsX.BOF And rsX.EOF Then
  strSQL = "CREATE TABLE dbo.objX (" & _
           "  ID int IDENTITY (1,1) NOT NULL," & _
           "  Name char(50) NULL)"
  cnnX.Execute strSQL
  strSQL = "CREATE UNIQUE INDEX IX_objX ON dbo.objX(ID)
  cnnS.Execute strSQL
End If
rsX.Close

Shade Every Other Row in Excel

Here is a simple macro that can shade every other row in Excel. Simple select an area in Excel then run this macro.

Sub ShadeEveryOtherRow()
    Dim Counter As Integer

'For every row in the current selection...
    For Counter = 1 To Selection.Rows.Count
        'If the row is an odd number (within the selection)...
        If Counter Mod 2 = 1 Then
            'Set the pattern to xlGray16.
            Selection.Rows(Counter).Interior.Pattern = xlGray16
        End If
    Next

End Sub

However sometimes, you'd like to avoid macros and the same effect can be done with manual tricks.

Here is a really easy manual trick.

  1. Shade a row. (This example is for rows but it can also be done for columns.)
  2. Select your shaded row plus an adjacent non-shaded row.
  3. Click on the Format Painter tool once.
  4. Select all the other rows.

Here is another manual trick (MS). This one is dynamic because you can add or delete rows and the formatting will adjust.

  1. Select the range that you want to format
  2. Choose Format, Conditional Formatting
  3. In the Conditional Formatting dialog box, select Formula Is from the drop-down list, and enter this formula:
    =MOD(ROW(),2)=0
  4. Click the Format button, select the Patterns tab, and specify a color for the shaded rows.
  5. Click OK twice to return to your worksheet.

Page Modified: (Hand noted: 2007-10-03 18:04:15Z) (Auto noted: 2007-11-17 06:36:35Z)