tips.jpg (3993 bytes)

 

This area is brand new and would like contributors. As of now, I will supply my own favorites. Also, I am planning on a search interface and until then, I'll post excerpts when ever I can make time. The following were requested most.

Please send your code tips to TipsTricks@pcgcorp.com

vb.jpg (2733 bytes)

If you require further assistance with any of these routines, I can send the complete Classes.

Giving your VB Toolbar a face lift (Explorer Style)
Sub MakeToolBarFlat(tbMain As Object)
Dim hwnd As Long, style As Long
Dim result As Long

     ' Find child window and get style bits
     hwnd = FindWindowEx(tbMain.hwnd, 0&, "ToolbarWindow32", vbNullString)
     style = SendMessage(hwnd, TB_GETSTYLE, 0&, 0&)

     ' Get the effect
     style = style Or TBSTYLE_FLAT

     ' Use the API to set the new style
     result = SendMessage(hwnd, TB_SETSTYLE, 0, style)

    tbMain.Refresh
End Sub
Get the User's Workstation name
Public Function Workstation() As String
On Error GoTo WorkstationErr ' Added on 7/15/98 5:52:31 PM -- %MJC%
'
Dim PCName As String
Dim x As Long

     PCName = Space$(256)
     x = GetComputerName(PCName, Len(PCName))
     PCName = Trim(PCName)

     Workstation = LCase(Left(PCName, Len(PCName) - 1))

     Exit Function ' %MJC%

WorkstationErr: ' %MJC%
     MsgBox "CSettings::Workstation()" ' %MJC%
     Exit Function ' %MJC%
End Function
Excerpt of a Binary Search, Linear Search, and Sorting from my CArrayRecordset Class.
Private Function BinarySearch(ColIndex As Integer, StrValue As Variant)
Dim Median As Long, Low As Long, Hi As Long

'If you have an Array with 1000 elements, it could take 1000 iterations before finding the result. Ouch, however, with a binary search,  you start at the middle 500 then determine wheather to go lower or higher. At that point your next stop is 250 or 750 and so on. After the first iteration, you've eliminated 500 records!!!

    Low = 0
    Hi = m_RecordCount - 1

    Do
        Median = (Low + Hi) / 2 'Locate 1/2 way point
        If LCase(StrValue) > LCase(m_Data(Median, ColIndex)) Then
             Low = Median + 1
        Else
            Hi = Median - 1
        End If

    Loop Until (StrValue = m_Data(Median, ColIndex)) Or (Low > Hi)

    If StrValue = m_Data(Median, ColIndex) Then
        m_RecPtr = Median
        BinarySearch = True
        RaiseEvent Reposition 'Notify Caller we moved to a new Text
    End If

End Function
Private Function LinearSearch(ColIndex As Integer, StrValue As Variant)
Dim Index As Integer, Low As Integer, Hi As Integer

    Low = 0
    Hi = m_RecordCount - 1

    For Index = Low To Hi
        If CStr(m_Data(Index, ColIndex)) = CStr(StrValue) Then
        m_RecPtr = Index 'Set the Text pointer to the found Text
        LinearSearch = True
        RaiseEvent Reposition 'Notify Caller we moved to a new Text
        Exit For
        End If
    Next Index

End Function
Private Function m_Sort(t_Data As Variant, Low As Long, Hi As Long, ColIndex As Integer)
Dim lTmpLow As Long, lTmpHi As Long
Dim lTmpMid As Long, vTempVal As Variant
Dim vTmpHold As Variant

    lTmpLow = Low
    lTmpHi = Hi

    ' Leave if there is nothing to sort
    If Hi <= Low Then Exit Function

    ' Find the middle to start comparing values
    lTmpMid = (Low + Hi) \ 2

    ' Move the item in the middle of the array to the temporary holding area as a point of reference while
    ' sorting. This will change each time we make a recursive call to this routine.
    vTempVal = t_Data(lTmpMid, ColIndex)

    ' Loop until we eventually meet in the middle
    Do While (lTmpLow <= lTmpHi)

        ' Always process the low end first. Loop as long the array data element is less than the data in
        ' the temporary holding area and the temporary low value is less than the maximum number of array
        ' elements. Also Compare in lower case

        Do While (LCase(t_Data(lTmpLow, ColIndex)) < LCase(vTempVal) And lTmpLow < Hi)
            lTmpLow = lTmpLow + 1
        Loop


        ' Now, we will process the high end. Loop as long the data in the temporary holding area is less
        ' than the array data element and the temporary high value is greater than the minimum number of array
        ' elements.
        Do While (LCase(vTempVal) < LCase(t_Data(lTmpHi, ColIndex)) And lTmpHi > Low)
            lTmpHi = lTmpHi - 1
        Loop

        ' if the temp low end is less than or equal to the temp high end, then swap places

  ' if the temp low end is less than or equal to the temp high end, then swap places
  If (lTmpLow <= lTmpHi) Then
      Dim Index As Integer
      For Index = 0 To m_FieldCount - 1   'Loop through all elements and move them as well
      vTmpHold = t_Data(lTmpLow, Index) ' Move the Low Field to Temp Hold
      t_Data(lTmpLow, Index) = t_Data(lTmpHi, Index) ' Move the high Field to the low
      t_Data(lTmpHi, Index) = vTmpHold ' Move the Temp Hold to the High ' Dcrement the temp high counter
  Next Index
  lTmpLow = lTmpLow + 1 ' Increment the temp low counter
  lTmpHi = lTmpHi - 1
  End If       


Loop

    ' If the minimum number of elements in the array is
    ' less than the temp high end, then make a recursive
    ' call to this routine.

    If (Low < lTmpHi) Then
        m_Sort t_Data, Low, lTmpHi, ColIndex
    End If

    ' If the temp low end is less than the maximum number
    ' of elements in the array, then make a recursive call
    ' to this routine. The high end is always sorted last.

    If (lTmpLow < Hi) Then
        m_Sort t_Data, lTmpLow, Hi, ColIndex
    End If

End Function
Simple Hex Format Function
Public Function LngToHex(n As Long) As Long
Dim sValue As String
Dim nValue As String
Dim Index As Integer

    nValue = Hex$(n)

    'Padding       
    For Index = 1 To 8 - Len(nValue)
        nValue = "0" & nValue
    Next Index

    sValue = "&H"

    For Index = 4 To 1 Step -1
        sValue = sValue + Mid$(nValue, Index * 2 - 1, 2)
    Next

    LngToHex = Val(sValue)
End Function

Excerpt from my CSQLAssist Class
Add your own Parameter Values instead of a parameter list
Function InsertParam(SQL As String, ParamValue As Variant, Optional StartPos As Integer)
On Error GoTo InsertParamErr
Dim n As Integer

     If StartPos = 0 Then StartPos = 1
          n = InStr(StartPos, SQL, "?")
          If n = 0 Then
          InsertParam = SQL
          Exit Function
     End If

    InsertParam = Mid(SQL, 1, n - 1) & ParamValue & Mid(SQL, n + 1)
    Exit Function

InsertParamErr:
     MsgBox "InsertParam(" & ParamValue & ")" & "Unable to Insert Parameter Into " & SQL
     Exit Function

End Function
ADO -- Working with recordsets offline then marshall them back when your done
'Local Objects
Function LoadJobs(nJobID as Long)
Dim ObjSvr as CMiddlerTier
Dim rs as ADODB.Recordset

    set rs = ObjSvr.GetJob(nJobID)

    rs.edit
        rs(0) = "New Value"
    rs.update

    ObjSvr.SaveJob rs
  
End Function

'Business Objects
Function ObjSvr (rs as Object)
Dim cn as New ADODB.Connection

    cn.Open DSN_DEFAULT

    set rs.ActiveConnection = cn
    rs.UpdateBatch
    set rs.ActiveConnection = Nothing
End Function

Function LoadByJobID(nID As Long) as Object
Dim rs As New ADOdb.Recordset
Dim cn As New ADOdb.Connection

    'Replace "'% if you are using as a COM Object under MTS
    '%Dim objContext As ObjectContext

    '%Set objContext = GetObjectContext()

    On Error GoTo LoadByJobIDErr
    cn.Open DSN_DEFAULT ' Open the connection

    rs.CursorLocation = adUseClientBatch ' Get the list of Categories
    rs.Open SQL_RunLoadByJobID & CStr(nID), cn, adOpenKeyset, adLockBatchOptimistic

    Set LoadByJobID = rs ' Setup the recordset to return
    Set rs.ActiveConnection = Nothing ' Disconnect the recordset
   

    cn.Close ' Close the connection

    '%objContext.SetComplete
    Exit Function

LoadByJobIDErr:
    '%objContext.SetAbort
    pError "Run_LoadByJobID(" & nID & ")", SQL_RunLoadByJobID & nID
    Exit Function
End Function