VB Tutor..

Creating Runtime Data Reports

2009-10-12T08:01:00.000-07:00

Private Sub Combo1_Click()
If Combo1.Text = "OBC" Then
DataReport1.Show
ElseIf Combo1.Text = "SC" Then
DataReport2.Show
Else
DataReport3.Show
End If
End Sub

User Control ,Creating OCX File in VB, Adding OCX to Components .

2009-10-12T07:11:00.000-07:00

Dim a, b
Dim sy

Private Sub cmdequal_Click()
b = Val(Text1.Text)
Text1.Text = Empty
If sy = "+" Then
Text1.Text = a + b
ElseIf sy = "-" Then
Text1.Text = a - b
ElseIf sy = "*" Then
Text1.Text = a * b
Else
Text1.Text = a / b
End If
End Sub

Private Sub cmdnums_Click(Index As Integer)
Text1.Text = Text1.Text & cmdnums(Index).Caption
End Sub

Private Sub cmdop_Click(Index As Integer)
a = Val(Text1.Text)
sy = cmdop(Index).Caption
Text1.Text = Empty
End Sub

Adodc.Recordset Connectivity

2009-07-12T10:24:00.000-07:00

Private Sub add_Click()

Adodc1.Recordset.AddNew

End Sub

Private Sub delete_Click()

Adodc1.Recordset.delete

End Sub

Private Sub last_Click()

Adodc1.Recordset.MoveLast

End Sub

Private Sub modify_Click()

Adodc1.Recordset.EditMode

End Sub

Private Sub next_Click()

Adodc1.Recordset.MoveNext

End Sub

Private Sub previous_Click()

Adodc1.Recordset.MovePrevious

End Sub

Private Sub save_Click()

Adodc1.Recordset.save

End Sub

List in memory

2009-02-07T04:10:00.000-08:00

struct node
{
int x;
struct node *next;
};

int main()
{
/* This won't change, or we would lose the list in memory */
struct node *root;
/* This will point to each node as it traverses the list */
struct node *conductor;

root = malloc( sizeof(struct node) );
root->next = 0;
root->x = 12;
conductor = root;
if ( conductor != 0 ) {
while ( conductor->next != 0)
{
conductor = conductor->next;
}
}
/* Creates a node at the end of the list */
conductor->next = malloc( sizeof(struct node) );

conductor = conductor->next;

if ( conductor == 0 )
{
printf( "Out of memory" );
return 0;
}
/* initialize the new memory */
conductor->next = 0;
conductor->x = 42;

return 0;
}

Show the 'File Open' Common Dialog via API calls

2009-02-04T06:47:00.000-08:00

To display a file open common dialog use the following routine (an example routine can be found at the bottom of this post):

Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long

Private Type OpenFileName
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'Purpose     :  Allows the user to select a file name from a local or network directory.
'Inputs      :  sInitDir            The initial directory of the file dialog.
'               sFileFilters        A file filter string, with the following format:
'                                   eg. "Excel Files;*.xls|Text Files;*.txt|Word Files;*.doc"
'               [sTitle]            The dialog title
'               [lParentHwnd]       The handle to the parent dialog that is calling this function.
'Outputs     :  Returns the selected path and file name or a zero length string if the user pressed cancel


Function BrowseForFile(sInitDir As String, Optional ByVal sFileFilters As String, Optional sTitle As String = "Open File", Optional lParentHwnd As Long) As String
    Dim tFileBrowse As OpenFileName
    Const clMaxLen As Long = 254
   
    tFileBrowse.lStructSize = Len(tFileBrowse)
   
    'Replace friendly deliminators with nulls
    sFileFilters = Replace(sFileFilters, "|", vbNullChar)
    sFileFilters = Replace(sFileFilters, ";", vbNullChar)
    If Right$(sFileFilters, 1) <> vbNullChar Then
        'Add final delimiter
        sFileFilters = sFileFilters & vbNullChar
    End If
   
    'Select a filter
    tFileBrowse.lpstrFilter = sFileFilters & "All Files (*.*)" & vbNullChar & "*.*" & vbNullChar
    'create a buffer for the file
    tFileBrowse.lpstrFile = String(clMaxLen, " ")
    'set the maximum length of a returned file
    tFileBrowse.nMaxFile = clMaxLen + 1
    'Create a buffer for the file title
    tFileBrowse.lpstrFileTitle = Space$(clMaxLen)
    'Set the maximum length of a returned file title
    tFileBrowse.nMaxFileTitle = clMaxLen + 1
    'Set the initial directory
    tFileBrowse.lpstrInitialDir = sInitDir
    'Set the parent handle
    tFileBrowse.hwndOwner = lParentHwnd
    'Set the title
    tFileBrowse.lpstrTitle = sTitle
   
    'No flags
    tFileBrowse.flags = 0

    'Show the dialog
    If GetOpenFileName(tFileBrowse) Then
        BrowseForFile = Trim$(tFileBrowse.lpstrFile)
        If Right$(BrowseForFile, 1) = vbNullChar Then
            'Remove trailing null
            BrowseForFile = Left$(BrowseForFile, Len(BrowseForFile) - 1)
        End If
    End If
End Function

Sub Test()
    BrowseForFile "c:\", "Excel File (*.xls);*.xls", "Open Workbook"
End Sub

Show the 'Choose a Color' Common Dialog

2009-02-04T06:46:00.000-08:00

Option Explicit
Private Declare Function ChooseColorA Lib "comdlg32.dll" (pChoosecolor As tChooseColor) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Type tChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'Purpose     :  Shows the Choose Color Dialog
'Inputs      :  N/A
'Outputs     :  Returns -1 if the user pressed cancel, else returns the selected color


Function ShowColor() As Long
    Dim tColor As tChooseColor
    Dim Custcolor(16) As Long
    Dim lReturn As Long, lThisColor As Long
    Dim abytCustomColors(0 To 16 * 4 - 1) As Byte
   
    For lThisColor = LBound(abytCustomColors) To UBound(abytCustomColors)
        abytCustomColors(lThisColor) = 0
    Next

    tColor.lStructSize = Len(tColor)
    tColor.hwndOwner = GetActiveWindow        'or Me.hwnd in VB
    tColor.hInstance = 1       'or App.hInstance in VB
    'Convert the custom colors to Unicode
    tColor.lpCustColors = StrConv(abytCustomColors, vbUnicode)
    tColor.flags = 0

    'Show the dialog
    If ChooseColorA(tColor) <> 0 Then
        ShowColor = tColor.rgbResult
    Else
        ShowColor = -1
    End If
End Function

Displaying The Windows Colour Dialog

2009-02-04T06:45:00.002-08:00

'Declare various Types, ENums and Functions.
Private Type udtCHOOSECOLOR
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    Flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Public Enum ColorDialogFlags
    UseInitialColor = &H1
    ShowCustomColorsOnLoad = &H2
    DisableCustomColors = &H4
    ShowHelp = &H8
    OnlySolidColors = &H80
    AllowAnyColor = &H100
    Default = &H1 Or &H100
End Enum

Private CDColor As udtCHOOSECOLOR

Private Declare Function ChooseColor Lib "comdlg32.dll" _
 Alias "ChooseColorA" (pChoosecolor As udtCHOOSECOLOR) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long


Public Function GetColor(ByVal T_hWnd As Long, ByVal Flags As ColorDialogFlags, _
 Optional ByVal InitialColor As Long) As Long
    'Dimension a variable.
    Dim CustColors(0 To 15) As Long
   
    'Set up the colour configuration.
    For I = 0 To 15
        CustColors(I) = vbWhite
    Next
    CDColor.Flags = Flags
    CDColor.hWndOwner = T_hWnd
    CDColor.hInstance = App.hInstance
    CDColor.lpCustColors = VarPtr(CustColors(0))
    CDColor.lStructSize = Len(CDColor)
    CDColor.rgbResult = InitialColor
    lngResult = ChooseColor(CDColor)
   
    'Get the colour that is selected.
    If lngResult = 1 And CommDlgExtendedError = 0 Then
        GetColor = CDColor.rgbResult
    Else
        GetColor = -1
    End If
End Function

Displaying The Search For Directory Dialog

2009-02-04T06:45:00.001-08:00

Private Declare Function SHBrowseForFolder _
 Lib "shell32" (lpbi As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList _
 Lib "shell32" (ByVal pidList As Long, _
 ByVal lpBuffer As String) As Long

Private Declare Function lstrcat Lib "kernel32" _
 Alias "lstrcatA" (ByVal lpString1 As String, ByVal _
 lpString2 As String) As Long

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

'Wrapper Function.
Private Sub DirBox(Msg As String, Directory As String)

    'Dimension some variables.
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim szTitle As String
    Dim tBrowseInfo As BrowseInfo
   
    'Set the message displayed on the dialog.
    szTitle = Msg
   
    'Set up the Type.
    With tBrowseInfo
       .hWndOwner = Me.hWnd
       .lpszTitle = lstrcat(szTitle, "")
       .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    End With
   
    'Show the dialog box.
    lpIDList = SHBrowseForFolder(tBrowseInfo)

    'Process the data returned.
    If (lpIDList) Then
       sBuffer = Space(MAX_PATH)
       SHGetPathFromIDList lpIDList, sBuffer
       sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
       Directory = sBuffer
    End If

End Sub

Displaying The Common Save Dialog

2009-02-04T06:43:00.001-08:00

'The API Function.
Public Declare Function GetSaveFileName Lib "comdlg32.dll" _
 Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

'Now come some Types.
Public Enum GFNFlags
    OFN_ALLOWMULTISELECT = &H200
    OFN_CREATEPROMPT = &H2000
    OFN_EXPLORER = &H80000
    OFN_FILEMUSTEXIST = &H1000
    OFN_HIDEREADONLY = &H4
    OFN_LONGNAMES = &H200000
    OFN_NOCHANGEDIR = &H8
    OFN_NODEREFERENCELINKS = &H100000
    OFN_NOLONGNAMES = &H40000
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOREADONLYRETURN = &H8000
    OFN_NOTESTFILECREATE = &H10000
    OFN_NOVALIDATE = &H100
    OFN_OVERWRITEPROMPT = &H2
    OFN_PATHMUSTEXIST = &H800
    OFN_READONLY = &H1
End Enum

Type OPENFILENAME
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   lpstrFile As String
   nMaxFile As Long
   lpstrFileTitle As String
   nMaxFileTitle As Long
   lpstrInitialDir As String
   lpstrTitle As String
   Flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type

'This is the wrapper Function.
Public Function SaveDialog(ByVal OwnerhWnd As Long, _
 ByVal Filters As String, ByVal FilterIndex As Long, _
 ByVal FNameLength As Long, _
 Optional ByVal InitFolder As String = "", _
 Optional ByVal InitFileName As String = "", _
 Optional ByVal dlgTitle As String = "", _
 Optional ByVal Flags As GFNFlags = 0) As String
    'Dimension some variables.
    Dim GFN As OPENFILENAME
   
    'Sort out some of the Type we will pass.
    GFN.lStructSize = Len(GFN)
    GFN.hwndOwner = OwnerhWnd
    GFN.hInstance = App.hInstance
   
    'Sort out the filters.
    For I = 1 To Len(Filters)
        If Mid$(Filters, I, 1) = "|" Then
            Filters = Left$(Filters, I - 1) & Chr$(0) & _
             Right$(Filters, Len(Filters) - I)
        End If
    Next
   
    'Finish setting up the Type.
    GFN.lpstrFilter = Filters
    GFN.nFilterIndex = FilterIndex
    GFN.lpstrFile = InitFileName & String$(FNameLength - Len(InitFileName), Chr$(0))
    GFN.nMaxFile = FNameLength
    GFN.lpstrFileTitle = String$(FNameLength, Chr$(0))
    GFN.nMaxFileTitle = FNameLength
    GFN.lpstrInitialDir = InitFolder
    GFN.lpstrTitle = dlgTitle
    GFN.Flags = Flags
   
    'Get and return the filename.
    If GetSaveFileName(GFN) >= 1 Then
        SaveDialog = GFN.lpstrFile
    Else
        SaveDialog = Chr$(0)
    End If

End Function

2009-02-04T06:37:00.000-08:00

'The API Function.
Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
 Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

'Now come some Types.
Public Enum GFNFlags
    OFN_ALLOWMULTISELECT = &H200
    OFN_CREATEPROMPT = &H2000
    OFN_EXPLORER = &H80000
    OFN_FILEMUSTEXIST = &H1000
    OFN_HIDEREADONLY = &H4
    OFN_LONGNAMES = &H200000
    OFN_NOCHANGEDIR = &H8
    OFN_NODEREFERENCELINKS = &H100000
    OFN_NOLONGNAMES = &H40000
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOREADONLYRETURN = &H8000
    OFN_NOTESTFILECREATE = &H10000
    OFN_NOVALIDATE = &H100
    OFN_OVERWRITEPROMPT = &H2
    OFN_PATHMUSTEXIST = &H800
    OFN_READONLY = &H1
End Enum

Type OPENFILENAME
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   lpstrFile As String
   nMaxFile As Long
   lpstrFileTitle As String
   nMaxFileTitle As Long
   lpstrInitialDir As String
   lpstrTitle As String
   Flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type

'This is the wrapper Function.
Public Function OpenDialog(ByVal OwnerhWnd As Long, _
 ByVal Filters As String, ByVal FilterIndex As Long, _
 ByVal FNameLength As Long, _
 Optional ByVal InitFolder As String = "", _
 Optional ByVal InitFileName As String = "", _
 Optional ByVal dlgTitle As String = "", _
 Optional ByVal Flags As GFNFlags = 0) As String
    'Dimension some variables.
    Dim GFN As OPENFILENAME
   
    'Sort out some of the Type we will pass.
    GFN.lStructSize = Len(GFN)
    GFN.hwndOwner = OwnerhWnd
    GFN.hInstance = App.hInstance
   
    'Sort out the filters.
    For I = 1 To Len(Filters)
        If Mid$(Filters, I, 1) = "|" Then
            Filters = Left$(Filters, I - 1) & Chr$(0) & _
             Right$(Filters, Len(Filters) - I)
        End If
    Next
   
    'Finish setting up the Type.
    GFN.lpstrFilter = Filters
    GFN.nFilterIndex = FilterIndex
    GFN.lpstrFile = InitFileName & String$(FNameLength - Len(InitFileName), Chr$(0))
    GFN.nMaxFile = FNameLength
    GFN.lpstrFileTitle = String$(FNameLength, Chr$(0))
    GFN.nMaxFileTitle = FNameLength
    GFN.lpstrInitialDir = InitFolder
    GFN.lpstrTitle = dlgTitle
    GFN.Flags = Flags
   
    'Get and return the filename.
    If GetOpenFileName(GFN) >= 1 Then
        OpenDialog = GFN.lpstrFile
    Else
        OpenDialog = Chr$(0)
    End If

End Function

Send the text in a range to a word document

2009-02-04T02:46:00.000-08:00

'Purpose : Sends the text in a range to a word application
'Inputs : rngSelection The range to send to a word document
'Outputs : Returns True on success.

Function WordSendRangeTo(rngSelection As Object, Optional sSaveToFile As String, Optional bShowWord As Boolean = False) As Boolean
Dim oWordApp As Object 'Early bound type = Word.Application
Dim oNewDoc As Object 'Early bound type = Word.Document
Dim oWordRange As Object 'Early bound type = Word.Range
Dim avVaules As Variant, vCell As Variant, sText As String

On Error GoTo ErrFailed
'Build up text to send to word document
avVaules = rngSelection.Value
For Each vCell In avVaules
sText = sText & vCell & " "
Next
sText = Trim$(sText)

'Create word objects
Set oWordApp = CreateObject("Word.Application")
Set oNewDoc = oWordApp.Documents.Add
Set oWordRange = oNewDoc.Words(1)

'Send text to word document
With oWordRange
.Text = sText
On Error Resume Next
Set .Font = rngSelection.Font
End With
On Error GoTo ErrFailed

'Save Document
If Len(sSaveToFile) Then
oNewDoc.SaveAs sSaveToFile
End If

If bShowWord Then
'Show Word
oWordApp.Visible = True
oWordApp.WindowState = 1 'wdWindowStateMaximize
Else
'Quit word
oWordApp.Quit
End If

WordSendRangeTo = True
GoTo ExitSub

ErrFailed:
'Error occurred
WordSendRangeTo = False

ExitSub:
'De-reference objects
Set oWordApp = Nothing
Set oNewDoc = Nothing
Set oWordRange = Nothing
End Function

'Demonstration routine
Sub Test()
WordSendRangeTo Selection, "C:\test.doc"
End Sub

Start, Stop and Pause NT Services

2009-02-04T02:45:00.000-08:00

Option Explicit

Public Enum eServiceState
essStopService
essStartService
essPauseService
End Enum

Private Declare Function CloseServiceHandle Lib "advapi32.dll" (ByVal hSCObject As Long) As Long
Private Declare Function ControlService Lib "advapi32.dll" (ByVal lHwndService As Long, ByVal dwControl As Long, lpServiceStatus As SERVICE_STATUS) As Long
Private Declare Function OpenSCManager Lib "advapi32.dll" Alias "OpenSCManagerA" (ByVal lpMachineName As String, ByVal lpDatabaseName As String, ByVal dwDesiredAccess As Long) As Long
Private Declare Function OpenService Lib "advapi32.dll" Alias "OpenServiceA" (ByVal hSCManager As Long, ByVal lpServiceName As String, ByVal dwDesiredAccess As Long) As Long
Private Declare Function QueryServiceStatus Lib "advapi32.dll" (ByVal lHwndService As Long, lpServiceStatus As SERVICE_STATUS) As Long
Private Declare Function StartService Lib "advapi32.dll" Alias "StartServiceA" (ByVal lHwndService As Long, ByVal dwNumServiceArgs As Long, ByVal lpServiceArgVectors As Long) As Long

Private Const SERVICES_ACTIVE_DATABASE = "ServicesActive"
Private Const SERVICE_CONTROL_STOP = &H1
Private Const SERVICE_CONTROL_PAUSE = &H2
Private Const SERVICE_STOPPED = &H1
Private Const SERVICE_START_PENDING = &H2
Private Const SERVICE_STOP_PENDING = &H3
Private Const SERVICE_RUNNING = &H4
Private Const SERVICE_CONTINUE_PENDING = &H5
Private Const SERVICE_PAUSE_PENDING = &H6
Private Const SERVICE_PAUSED = &H7
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SC_MANAGER_CONNECT = &H1
Private Const SC_MANAGER_CREATE_SERVICE = &H2
Private Const SC_MANAGER_ENUMERATE_SERVICE = &H4
Private Const SC_MANAGER_LOCK = &H8
Private Const SC_MANAGER_QUERY_LOCK_STATUS = &H10
Private Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
Private Const SC_MANAGER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SC_MANAGER_CONNECT Or SC_MANAGER_CREATE_SERVICE Or SC_MANAGER_ENUMERATE_SERVICE Or SC_MANAGER_LOCK Or SC_MANAGER_QUERY_LOCK_STATUS Or SC_MANAGER_MODIFY_BOOT_CONFIG)
Private Const SERVICE_QUERY_CONFIG = &H1
Private Const SERVICE_CHANGE_CONFIG = &H2
Private Const SERVICE_QUERY_STATUS = &H4
Private Const SERVICE_ENUMERATE_DEPENDENTS = &H8
Private Const SERVICE_START = &H10
Private Const SERVICE_STOP = &H20
Private Const SERVICE_PAUSE_CONTINUE = &H40
Private Const SERVICE_INTERROGATE = &H80
Private Const SERVICE_USER_DEFINED_CONTROL = &H100
Private Const SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG Or SERVICE_QUERY_STATUS Or SERVICE_ENUMERATE_DEPENDENTS Or SERVICE_START Or SERVICE_STOP Or SERVICE_PAUSE_CONTINUE Or SERVICE_INTERROGATE Or SERVICE_USER_DEFINED_CONTROL)

Private Type SERVICE_STATUS
dwServiceType As Long
dwCurrentState As Long
dwControlsAccepted As Long
dwWin32ExitCode As Long
dwServiceSpecificExitCode As Long
dwCheckPoint As Long
dwWaitHint As Long
End Type

'Purpose : Returns the status of a NT Service
'Inputs : sServiceName The name of the service to test
' [sComputerName] The name of the machine to test the service status on.
' If unspecified uses the local machine
'Outputs : Returns a English description of the service status

Public Function ServiceStatus(sServiceName As String, Optional sComputerName As String) As String
Dim tServiceStat As SERVICE_STATUS
Dim lHwndSManager As Long
Dim lHwndService As Long
Dim hServiceStatus As Long

'Check the input data
If InStr(1, sServiceName, " ") Then
Debug.Print "Service names cannot contain spaces. Use the 'Service Name' of the service, not the 'Display Name'"
Exit Function
End If

ServiceStatus = ""
'Open the service manager
lHwndSManager = OpenSCManager(sComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If lHwndSManager <> 0 Then
'Open the service
lHwndService = OpenService(lHwndSManager, sServiceName, SERVICE_ALL_ACCESS)
If lHwndService <> 0 Then
'Query the service
hServiceStatus = QueryServiceStatus(lHwndService, tServiceStat)
If hServiceStatus <> 0 Then
Select Case tServiceStat.dwCurrentState
Case SERVICE_STOPPED
ServiceStatus = "Stopped"
Case SERVICE_START_PENDING
ServiceStatus = "Start Pending"
Case SERVICE_STOP_PENDING
ServiceStatus = "Stop Pending"
Case SERVICE_RUNNING
ServiceStatus = "Running"
Case SERVICE_CONTINUE_PENDING
ServiceStatus = "Coninue Pending"
Case SERVICE_PAUSE_PENDING
ServiceStatus = "Pause Pending"
Case SERVICE_PAUSED
ServiceStatus = "Paused"
End Select
End If
'Close the service
CloseServiceHandle lHwndService
End If
'Close the service mananger
CloseServiceHandle lHwndSManager
End If
End Function

'Purpose : Changes the state of an NT Service
'Inputs : sServiceName The name of the service to test
' [sComputerName] The name of the machine to test the service status on.
' If unspecified uses the local machine
'Outputs : N/A

Public Function ServiceStateChange(sServiceName As String, eState As eServiceState, Optional sComputerName As String) As Boolean
Dim tServiceStatus As SERVICE_STATUS
Dim lHwndSManager As Long
Dim lHwndService As Long
Dim lRes As Long

'Check the input data
If InStr(1, sServiceName, " ") Then
Debug.Print "Service names cannot contain spaces. Use the 'Service Name' of the service, not the 'Display Name'"
ServiceStateChange = False
Exit Function
End If

'Open the service manager
lHwndSManager = OpenSCManager(sComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If lHwndSManager <> 0 Then
'Open the service
lHwndService = OpenService(lHwndSManager, sServiceName, SERVICE_ALL_ACCESS)
If lHwndService <> 0 Then
Select Case eState
Case essPauseService
'Pause the service
lRes = ControlService(lHwndService, SERVICE_CONTROL_PAUSE, tServiceStatus)
Case essStartService
'Start the service
lRes = StartService(lHwndService, 0, 0)
Case essStopService
lRes = ControlService(lHwndService, SERVICE_CONTROL_STOP, tServiceStatus)
Case Else
Debug.Print "Invalid Service State"
Debug.Assert False
End Select

If lRes Then
'Success
ServiceStateChange = True
Else
'Failed
ServiceStateChange = False
Debug.Print "Error in ServiceStateChange: " & Err.LastDllError
Debug.Assert False
End If
CloseServiceHandle lHwndService
End If
CloseServiceHandle lHwndSManager
Else
Debug.Print "Failed to open service mananger!"
Debug.Assert False
ServiceStateChange = False
End If
End Function

'Demonstration routine using the "Windows Time" service
Sub Test()
Dim sStatus As String

sStatus = ServiceStatus("W32Time")
Debug.Print "Event Log is now " & sStatus

Call ServiceStateChange("W32Time", essStopService)
sStatus = ServiceStatus("W32Time")
Debug.Print "Event Log is now " & sStatus

Call ServiceStateChange("W32Time", essStartService)
sStatus = ServiceStatus("Eventlog")
Debug.Print "Event Log is now " & sStatus
End Sub

Determining the system folder locations

2009-02-04T02:43:00.000-08:00

Option Explicit

Public Enum epPath
    CSIDL_DESKTOP = &H0
    CSIDL_INTERNET = &H1
    CSIDL_PROGRAMS = &H2
    CSIDL_CONTROLS = &H3
    CSIDL_PRINTERS = &H4
    CSIDL_PERSONAL = &H5
    CSIDL_FAVORITES = &H6
    CSIDL_STARTUP = &H7
    CSIDL_RECENT = &H8
    CSIDL_SENDTO = &H9
    CSIDL_BITBUCKET = &HA
    CSIDL_STARTMENU = &HB
    CSIDL_DESKTOPDIRECTORY = &H10
    CSIDL_DRIVES = &H11
    CSIDL_NETWORK = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14
    CSIDL_TEMPLATES = &H15
    CSIDL_COMMON_STARTMENU = &H16
    CSIDL_COMMON_PROGRAMS = &H17
    CSIDL_COMMON_STARTUP = &H18
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19
    CSIDL_APPDATA = &H1A
    CSIDL_PRINTHOOD = &H1B
    CSIDL_LOCAL_APPDATA = &H1C
    CSIDL_ALTSTARTUP = &H1D
    CSIDL_COMMON_ALTSTARTUP = &H1E
    CSIDL_COMMON_FAVORITES = &H1F
    CSIDL_INTERNET_CACHE = &H20
    CSIDL_COOKIES = &H21
    CSIDL_HISTORY = &H22
    CSIDL_COMMON_APPDATA = &H23
    CSIDL_WINDOWS = &H24
    CSIDL_SYSTEM = &H25
    CSIDL_PROGRAM_FILES = &H26
    CSIDL_MYPICTURES = &H27
    CSIDL_PROFILE = &H28
    CSIDL_SYSTEMX86 = &H29
    CSIDL_PROGRAM_FILESX86 = &H2A
    CSIDL_PROGRAM_FILES_COMMON = &H2B
    CSIDL_PROGRAM_FILES_COMMONX86 = &H2C
    CSIDL_COMMON_TEMPLATES = &H2D
    CSIDL_COMMON_DOCUMENTS = &H2E
    CSIDL_COMMON_ADMINTOOLS = &H2F
    CSIDL_ADMINTOOLS = &H30
    CSIDL_FLAG_CREATE = &H8000&
    CSIDL_FLAG_DONT_VERIFY = &H4000
    CSIDL_FLAG_MASK = &HFF00
End Enum


Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Private Type SHITEMID
    CB As Long
    AbID As Byte
End Type

Private Type ITEMIDLIST
    Mkid As SHITEMID
End Type

Public Type SpecialFolder
    FolderPath As String
    FolderType As epPath
End Type

'Purpose     :  Returns an array of special folders
'Inputs      :
'Outputs     :  Returns an array of the special folders.


Function GetAllSpecialFolders() As SpecialFolder()
    Dim lThisFolder As Long, lNumFolders As Long
    Dim sFolderPath As String
    Dim resultArray() As SpecialFolder
   
    Const clMaxFolders As Long = 255
   
    On Error GoTo ErrFailed
    Erase resultArray
    'Return All Folders
    ReDim resultArray(1 To clMaxFolders)
    For lThisFolder = 0 To clMaxFolders
        sFolderPath = UCase$(GetSpecialFolder(lThisFolder))
        If Len(sFolderPath) Then
            lNumFolders = lNumFolders + 1
            resultArray(lNumFolders).FolderPath = sFolderPath
            resultArray(lNumFolders).FolderType = lThisFolder
        End If
    Next
   
    If lNumFolders Then
        ReDim Preserve resultArray(1 To lNumFolders)
        GetAllSpecialFolders = resultArray
    Else
        GetAllSpecialFolders = Empty
    End If
   
    Exit Function
ErrFailed:
    GetAllSpecialFolders = Empty
End Function

Function GetSpecialFolder(eFolderID As epPath) As String
    Dim tRetVal As Long, sBuffer As String
    Dim tIDL As ITEMIDLIST
    Const NO_ERROR = 0
   
    'Get the special folder
    tRetVal = SHGetSpecialFolderLocation(100&, eFolderID, tIDL)
    If tRetVal = NO_ERROR Then
        'Create a buffer
        sBuffer = Space$(512)
        'Get the path from the IDList
        tRetVal = SHGetPathFromIDList(ByVal tIDL.Mkid.CB, ByVal sBuffer)
        'Remove the unnecesarry chr$(0)'s
        GetSpecialFolder = Left$(sBuffer, InStr(1, sBuffer, vbNullChar) - 1)
        If Right$(GetSpecialFolder, 1) <> "\" And Len(GetSpecialFolder) > 0 Then
            GetSpecialFolder = GetSpecialFolder & "\"
        End If
    End If
End Function

'Demonstration routine
Sub Test()
    Dim atFolders() As SpecialFolder, tFolder As SpecialFolder, folder As Integer
    'Get all special folders
    atFolders = GetAllSpecialFolders()
    For folder = 1 To UBound(atFolders)
        tFolder = atFolders(folder)
        Debug.Print "Type: " & tFolder.FolderType & ". Path: " & tFolder.FolderPath
    Next

    'Get the start menu folder location
    Debug.Print GetSpecialFolder(CSIDL_STARTMENU)
End Sub

Preview an Access Database Report

2009-02-03T07:16:00.000-08:00

The function below can be used to preview a report created in MS Access.

'Purpose   :    Preview an Access Report from VB
'Inputs    :    sAccessDBPath           The path and filename of the access database containing the report to show
'               sReportName             The name of the report to show
'Outputs   :    Returns an empty string on success, else returns an error message.


Function AccessShowReport(sAccessDBPath As String, sReportName As String) As String
    Dim oAccess As Object 'Access.Application
   
    On Error GoTo ErrFailed
    AccessShowReport = ""
    'Create Access
    Set oAccess = CreateObject("Access.Application")
    'Open Database
    oAccess.OpenCurrentDatabase sAccessDBPath
    'Open report
    oAccess.DoCmd.OpenReport sReportName, 0 'acViewNormal
    'Show Access Report
    oAccess.Visible = True
    oAccess.CloseCurrentDatabase
    Set oAccess = Nothing
    Exit Function

ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    AccessShowReport = Err.Description
    If oAccess Is Nothing = False Then
        oAccess.CloseCurrentDatabase
        Set oAccess = Nothing
    End If
End Function

Repoint an Access Link table using ADO-ADOX

2009-02-03T07:07:00.000-08:00

The following routine repoints a link table to a different database.

'Purpose     :  Updates the underlying source of a link table in an Access database
'Inputs      :  sLinkDatabasePath path to the database.
'               sLinkToNewDatabase The path to the database repoint the link to.
'               sLinkTableName name of the link table to repoint.
'Outputs     :  Returns True if succeeded in repointing the table
'Notes       :  Requires a reference to reference to both ADO (MS ActiveX Data Objects) and MSADOX.DLL
'               (MS ADO Ext. 2.5 DLL and Security).
'Revisions   :

Function AccessLinkTableUpdate(sLinkDatabasePath As String, sLinkToNewDatabase As String, sLinkTableName As String) As Boolean

Dim catDB As ADOX.Catalog
   
 On Error GoTo ErrFailed
 Set catDB = New ADOX.Catalog
    'Open a catalog on the database which contains the table to refresh.
.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sLinkDatabasePath
 catDB.Tables(sLinkTableName).Type = "LINK" Then
.Tables(sLinkTableName).Properties("Jet OLEDB:Link Datasource") = sLinkToNewDatabase
AccessLinkTableUpdate = True
    End If
    Set catDB = Nothing
    Exit Function

ErrFailed:
    On Error GoTo 0
    AccessLinkTableUpdate = False
End Function

Read data from a workbook using ADO

2009-02-03T07:03:00.000-08:00

The following code reads data from closed Excel workbooks using ADO with an ODBC driver.

Purpose     :  Extracts data from a closed workbook to an array
Inputs      :  sSourceFile                     The path and file name of the workbook to read data from.
               sRange                          The range reference (or named range) to read the data from.
               [sSheetName]                    The name of the sheet to return the data from. If not specified returns
                                               data from first sheet.
               [bReturnHeadings]               If True returns the Column Headings (i.e. the first row in the range).
                                               Note: This alters the shape of the output array to an array in an array.
Outputs     :  Returns a 2d variant array containing the values in the specified range.
Notes       :  Requires a reference to the Microsoft ActiveX Data Objects library
Could also use OLEDB JET 4.0 Driver 

"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sSourceFile & ";Extended Properties=""Excel 8.0;HDR=Yes"""


Function WorkbookReadRange(sSourceFile As String, sRange As String, Optional sSheetName As String, Optional bReturnHeadings As Boolean) As Variant
    Dim conWkb As ADODB.Connection, rsWkbCells As ADODB.Recordset, sConString As String
    Dim lThisField As Long, avResults As Variant, avHeadings As Variant
   
    On Error GoTo ErrFailed
    sConString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & sSourceFile
    Set conWkb = New ADODB.Connection
    'open connection
    conWkb.Open sConString
    If Len(sSheetName) Then
        'Get data from specified sheet
        Set rsWkbCells = conWkb.Execute("Select * from " & Chr(34) & sSheetName & "$" & sRange & Chr$(34))
    Else
        'Get data from first sheet
        Set rsWkbCells = conWkb.Execute("Select * from " & sRange)
    End If
    If rsWkbCells.EOF Then
        'Return a 1d array
        'Get headings
        ReDim avHeadings(0 To 0, 0 To rsWkbCells.Fields.Count - 1)
        For lThisField = 0 To rsWkbCells.Fields.Count - 1
            avHeadings(0, lThisField) = rsWkbCells.Fields(lThisField).Name
        Next
        WorkbookReadRange = avHeadings
    Else
        'Return a 2d array
        If bReturnHeadings Then
            'Get cells
            avResults = rsWkbCells.GetRows
            'Get headings
            ReDim avHeadings(0 To rsWkbCells.Fields.Count - 1, 0 To 0)
            For lThisField = 0 To rsWkbCells.Fields.Count - 1
                avHeadings(lThisField, 0) = rsWkbCells.Fields(lThisField).Name
            Next
            WorkbookReadRange = Array(avHeadings, avResults)
        Else
            'Get cells
            WorkbookReadRange = rsWkbCells.GetRows
        End If
    End If
    'Disconnect and destroy DB objects
    rsWkbCells.Close
    conWkb.Close
    Set rsWkbCells = Nothing
    Set conWkb = Nothing
    On Error GoTo 0
    Exit Function

ErrFailed:
   'Return error message
    WorkbookReadRange = Err.Description

    If conWkb.State <> adStateClosed Then
        conWkb.Close
    End If
  
    Set rsWkbCells = Nothing
    Set conWkb = Nothing
End Function

'Demonstration Routine
Sub Test()
    Dim avCellValues As Variant, vThisCell As Variant
    avCellValues = WorkbookReadRange("C:\book1.xls", "A1:B2", "Sheet1")
    If IsArray(avCellValues) Then
        For Each vThisCell In avCellValues
            Debug.Print vThisCell
        Next
    End If
End Sub

Return table names from Access-SQL Server

2009-02-03T06:59:00.000-08:00

The function below uses ADOX (Microsoft ADO Ext 2.5 for DLL and Security) to return all the table names for a given connection or connection string.

Purpose : Returns all the tables in an Access or SQL Server database
Inputs : A valid connection string or ADO Connection
Outputs : A collection of Table Names

CODE :

Public Function TableNames(Optional sConnectionString As String, Optional cCN As ADODB.Connection) As Collection
Dim oCatalog As New ADOX.Catalog, colTableNames As New Collection
Dim oTables As ADOX.Tables, oTable As ADOX.Table
Dim oConnection As New ADODB.Connection

On Error GoTo ExitSub
If Len(sConnectionString) Then
oConnection.ConnectionString = sConnectionString
oConnection.Open sConnectionString
Else
Set oConnection = cCN
End If
Set oCatalog.ActiveConnection = oConnection
Set oTables = oCatalog.Tables

For Each oTable In oTables
colTableNames.Add oTable.Name
Next
Set TableNames = colTableNames

ExitSub:
On Error Resume Next
If Len(sConnectionString) Then
'Close Temporary Connection
If oConnection.State <> 0 Then
oConnection.Close
End If
End If
Set oConnection = Nothing
Set oCatalog = Nothing
Set oTable = Nothing
Set oTables = Nothing
Exit Function
ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Resume ExitSub
End Function

'Example
Private Sub Form_Load()
Dim colTableNames As Collection, vTable As Variant
Set colTableNames = TableNames("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Inetpub\GFX-IT\database\support.mdb; Persist Security Info=False")
For Each vTable In colTableNames
Debug.Print "Table Name: " & vTable
Next
End Sub

Retrieve a list of the users logged on to an Access-Jet Database

2009-02-03T06:54:00.000-08:00

Option Explicit

'----------Type to hold results------------
'For each person who opens a shared database, the Jet database engine writes an entry
'in the database's .ldb file. The size of each .ldb entry is 64 bytes. The first 32
'bytes contains the computer name. The second 32 bytes contains the
'security name (such as Admin).
Private Type tDBUser
    UserName As String * 32
    SecurityName As String * 32
End Type


'Purpose     :  Retreives a list of users attached to an Access Database by parsing the ldb file
'Inputs      :  asUsers                         See outputs
'               sLDBFilePath                    The path and file name of the ldb file
'Outputs     :  asUsers                         A 2d string array 1 to 2, 1 to Number of users
'                                               Where   asUsers(1,1)      =       First user name
'                                                       asUsers(2,1)      =       User's security access
'               Returns 0 if their are no users or the lock file doesn't exist.
'               Returns -1 on error.


Function DatabaseUsers(ByRef asUsers() As String, sLDBFilePath As String) As Long
    Const clMaxUsers As Long = 255      'The maximum number of concurrent users that the Jet database engine supports is 255
    Dim iFileNum As Integer
    Dim tThisUser As tDBUser
   
    On Error GoTo ErrFailed
    If Len(Dir$(sLDBFilePath)) > 0 And Len(sLDBFilePath) > 0 Then
        'Lock file exists, open file.
        iFileNum = FreeFile
        Open sLDBFilePath For Random As #iFileNum Len = Len(tThisUser)
        'Create buffer to store results
        ReDim asUsers(1 To 2, 1 To clMaxUsers)
        'Read data into fixed length type
        Get iFileNum, 1, tThisUser
        Do While Not EOF(iFileNum)
            DatabaseUsers = DatabaseUsers + 1
            asUsers(1, DatabaseUsers) = Left$(tThisUser.UserName, InStr(1, tThisUser.UserName, vbNullChar) - 1)
            asUsers(2, DatabaseUsers) = Left$(tThisUser.SecurityName, InStr(1, tThisUser.SecurityName, vbNullChar) - 1)
            'Read next record
            Get iFileNum, DatabaseUsers + 1, tThisUser
        Loop
        'Close file
        Close #iFileNum
        'Resize results
        ReDim Preserve asUsers(1 To 2, 1 To DatabaseUsers)
    Else
        'No users attached
        Erase asUsers
    End If
    Exit Function
ErrFailed:
    DatabaseUsers = -1
    Erase asUsers
End Function

'Demonstration routine
Sub Test()
    Dim asUsers() As String, lNumUsers As Long, lThisUser As Long

    lNumUsers = DatabaseUsers(asUsers, "D:\Work\Visual Basic\Net Send\NetSend.ldb")
    For lThisUser = 1 To lNumUsers
        Debug.Print "User Name: " & asUsers(1, lThisUser)
        Debug.Print "Security : " & asUsers(2, lThisUser)
    Next
End Sub

Returning an asynchronous client side recorset with ADO

2009-02-03T06:49:00.000-08:00

The following function below illustrates how you would run an ADO client side (disconnected) query asynchronously:

Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

'Purpose     :  Executes a disconnect ADO query asynchronously.
'Inputs      :  sSql                            The SQL to execute.
'               oCon                            The connection to execute against.
'               [lQueryTimeout]                 If specified is the amount of time to wait (in secs) before aborting the query
'Outputs     :  Returns a recordset contain the results of the query


Function RecordsetOpenAsync(sSql As String, oCon As ADODB.Connection, Optional lQueryTimeout As Long = -1) As ADODB.Recordset
    Dim oRs As ADODB.Recordset, lQueryTimeoutOld As Long
    On Error GoTo ErrFailed
   
    'Create recordset
    Set oRs = New Recordset
   
    If lQueryTimeout <> -1 Then
        'Store and set query timeout
        lQueryTimeoutOld = oCon.CommandTimeout
        oCon.CommandTimeout = lQueryTimeout
    End If
   
    'Set cursor to client
    oRs.CursorLocation = adUseClient
   
    'Open recorset
    'Using the "adAsyncExecute" option means the query returns immediately. If you
    'use the "adAsync" option the query will return after "Initial Fetch Size" rows have been
    'returned (see oRs.Properties("Initial Fetch Size") + oRs.Properties("Background Fetch Size"))
    oRs.Open sSql, oCon, adOpenStatic, adLockBatchOptimistic, adAsyncExecute
   
    'Wait for recordset to finish fetching
    Do While oRs.state <> adStateOpen
        Sleep 20
        DoEvents
    Loop
   
    'Disconnect recordset
    If oRs.EOF = False Then
        'Results are pending. Move the cursor across the results to fetch them (onto the client)
        oRs.MoveLast
        oRs.MoveFirst
    End If
    'Release reference to connection
    Set oRs.ActiveConnection = Nothing
   
    If lQueryTimeout <> -1 Then
        'Restore query timeout
        oCon.CommandTimeout = lQueryTimeoutOld
    End If
   
    'Return recordset
    Set RecordsetOpenAsync = oRs
   
    Exit Function
   
ErrFailed:
    'Error occured
    Debug.Print Err.Description
    Debug.Assert False
    Set RecordsetOpenAsync = Nothing
End Function

Updating a database using a disconnected recordset

2009-02-03T06:45:00.000-08:00

Option Explicit

'Purpose     :  Open a disconnected recordset.
'Inputs      :  oCon                        The connection to open the recordset on.
'               sSQL                        The SQL to open the recordset with.
'               oRS                         The resulting recordset.
'Outputs     :  Returns True if the recordset was opened and contained results.


Public Function RSOpenDisconnected(oCon As ADODB.Connection, sSQL As String, oRS As ADODB.Recordset, Optional eLocking As LockTypeEnum = adLockBatchOptimistic) As Boolean
    On Error GoTo ErrFailed
    If oCon.State = adStateOpen Then
        'Connection is open
        Set oRS = New ADODB.Recordset
        'Set cursor to client (i.e. Local Machine)
        oRS.CursorLocation = adUseClient
        'Open Recordset (NB. The CursorType is always "adOpenStatic" for client-side cursors)
        oRS.Open sSQL, oCon, adOpenStatic, eLocking
        'Set connection to nothing (disconnect recordset)
        Set oRS.ActiveConnection = Nothing
        If oRS.EOF = False Then
            'Return results
            RSOpenDisconnected = True
        Else
            'Empty recorset
            RSOpenDisconnected = False
        End If
    End If
    Exit Function

ErrFailed:
    Debug.Print "Failed to open recordset: " & Err.Description
    Debug.Assert False  'Error occurred
    RSOpenDisconnected = False
    On Error GoTo 0
End Function


'Demonstrates how to open a disconnected recordset and then update a value in
'a field in the database.
Sub Test()
    Dim oRS As ADODB.Recordset
    Dim oConn As ADODB.Connection
    Const clRecordUpdated As Long = -2147217864
   
    On Error GoTo ErrUpdateFailed
    'Open a connection to a database
    Set oConn = New ADODB.Connection
    oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyPath\MyDatabase.mdb; Persist Security Info=False"
    'Open a disconnected recordset
    RSOpenDisconnected oConn, "Select * from tblHoliday", oRS
    'Update a field in the recordset
    oRS.Fields("MyField").Value = "My New Value"
    'Reconnect to database
    Set oRS.ActiveConnection = oConn
   
    'Update table
    oRS.UpdateBatch
   
    'Close the connection
    oRS.Close
    Set oRS = Nothing
    oConn.Close
    Set oConn = Nothing
   
    Exit Sub
   
ErrUpdateFailed:
    If Err.Number = clRecordUpdated Then
        MsgBox "The record you altered has been altered by another user... " & vbNewLine & Err.Description, vbCritical
    Else
        MsgBox "Error in disconnected update routine... " & vbNewLine & Err.Description, vbCritical
    End If
End Sub

Adding a horizontal scroll bar to a listbox

2009-01-30T22:52:00.000-08:00

Option Explicit

Private Declare Function SendMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


'Purpose     :  Adds items to a listbox and if neccessary sets the
'               width of the horizontal scroll bar to the maximum width of the
'               items in the listbox.
'Inputs      :  lbListbox                   The listbox to add the item to.
'               sItemText                   The text to add to the listbox.
'               [iIndex]                    The position within the object where the new item or row is placed.
'Outputs     :  Returns True on success
'Notes       :
'Revisions   :
'Assumptions : 

Function ListboxAddItem(lbListbox As ListBox, sItemText As String, Optional iIndex As Integer = -1) as Boolean
    Dim fTextWidth As Single, fExistScrollWidth As Single
    Dim oParentFont As StdFont
    Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

    On Error Resume Next

    'Add item to listbox
    If iIndex > -1 Then
        lbListbox.AddItem sItemText, iIndex
    Else
        lbListbox.AddItem sItemText
    End If

    'Store the form's original font
    Set oParentFont = lbListbox.Parent.Font
    'Set the form's font to the listbox's font
    Set lbListbox.Parent.Font = lbListbox.Font
    'Get width of text on the form
    fTextWidth = lbListbox.Parent.TextWidth(sItemText & " ")        'Extra space allows for vertical scroll bar
    'Restore the form's font
    Set lbListbox.Parent.Font = oParentFont
   
    'Get the width of the existing scroll bar
    fExistScrollWidth = SendMessageA(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)
   
    If lbListbox.Parent.ScaleMode = vbTwips Then
        'Change twips to pixels
        fTextWidth = fTextWidth / Screen.TwipsPerPixelX
    End If
   
    If fTextWidth > fExistScrollWidth Then
        'Increase width of scroll bar
        Call SendMessageA(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
    End If
    ListboxAddItem = (Err.Number = 0)
End Function


'Purpose     :  Modifies the text of an item in a listbox and if neccessary sets the
'               width of the horizontal scroll bar to the maximum width of the
'               items in the listbox.
'Inputs      :  lbListbox                   The listbox to update the item in.
'               sNewItemText                The new text for the item in the listbox.
'               [iIndex]                    The index of the item to update within the listbox.
'Outputs     :  Returns True on Success
'Notes       :
'Revisions   :
'Assumptions :

Function ListboxUpdateItem(lbListbox As ListBox, sNewItemText As String, iIndex As Integer) As Boolean
    Dim fTextWidth As Single, fExistScrollWidth As Single
    Dim oParentFont As StdFont
    Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193
   
    'Add item to listbox
    On Error GoTo ErrFailed
    If lbListbox.List(iIndex) <> sNewItemText Then
        lbListbox.List(iIndex) = sNewItemText
        'Get width of text
        Set oParentFont = lbListbox.Parent.Font
        Set lbListbox.Parent.Font = lbListbox.Font
        fTextWidth = lbListbox.Parent.TextWidth(sNewItemText & " ")        'Extra space allows for vertical scroll bar
        Set lbListbox.Parent.Font = oParentFont
        fExistScrollWidth = SendMessageA(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)
       
        If lbListbox.Parent.ScaleMode = vbTwips Then
            'Change twips to pixels
            fTextWidth = fTextWidth / Screen.TwipsPerPixelX
        End If
       
        If fTextWidth > fExistScrollWidth Then
            'Increase width of scroll bar
            Call SendMessageA(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
        End If
    End If
    ListboxUpdateItem = True

    Exit Function
   
ErrFailed:
    Debug.Print "Error in ListboxAddItem: " & lbListbox.Name & " Description: " & Err.Description
    ListboxUpdateItem = False
End Function


'Purpose     :  Adds a horizontal scroll bar to a listbox
'Inputs      :  lbListbox                   The listbox to add the scrollbar to.
'Outputs     :  Returns True on success
'Notes       :
'Revisions   :
'Assumptions :

Function ListboxAddHorizontalScollBar(lbListbox As ListBox) As Boolean
    On Error GoTo ErrFailed
    Dim fTextWidth As Single
    Dim oParentFont As StdFont, fExistScrollWidth As Single
    Dim lThisListItem As Long, fMaxScollWidth As Single, lMaxTextLen As Long
    Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

    'Add item to listbox
    On Error GoTo ErrFailed
    'Set the parent font
    Set oParentFont = lbListbox.Parent.font
    Set lbListbox.Parent.font = lbListbox.font
    Set lbListbox.Parent.font = oParentFont

    'Determine max. length of text
    For lThisListItem = 0 To lbListbox.ListCount - 1
        If Len(lbListbox.list(lThisListItem)) > lMaxTextLen Then
            lMaxTextLen = Len(lbListbox.list(lThisListItem))
        End If
    Next

    'Get the text length
    fTextWidth = lbListbox.Parent.TextWidth(String(lMaxTextLen + 1, "W"))       'Extra space allows for vertical scroll bar
    'Restore the form's font
    Set lbListbox.Parent.font = oParentFont

    'Get the width of the existing scroll bar
    fExistScrollWidth = SendMessage(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)

    If lbListbox.Parent.ScaleMode = vbTwips Then
        'Change twips to pixels
        fTextWidth = fTextWidth / Screen.TwipsPerPixelX
    End If

    If fTextWidth > fExistScrollWidth Then
        'Increase width of scroll bar
        Call SendMessage(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
    End If
    ListboxAddHorizontalScollBar = (err.number = 0)
   
    Exit Function

ErrFailed:
    Debug.Print err.description
    Debug.Assert False
    ListboxAddHorizontalScollBar = (err.number = 0)
End Function

Calling ODBC from ADO to connect to thirdparty driver

2009-01-30T22:49:00.000-08:00

Dim ADOCN As New ADODB.Connection
Dim ADORS As New ADODB.Recordset
Dim mysql  As String
With ADOCN
'here how to call odbc from ADO!
   .ConnectionString = "DSN=odbc namet;UID=YOURUSERID;PWD=YOURPASSWORD;"
.Mode = adModeReadOnly
   .Open
End With

With ADORS
   .CursorLocation = adUseClient
   .CursorType = adOpenKeyset
   .LockType = adLockOptimistic
   .ActiveConnection = ADOCN
    mysql = "select whatever from my table"
   .Source = mysql
   .Open
'for good preformance, I did store the record set in variant type variable so I can disconnect from host sooner

.ctiveConnection = Nothing
    myrows = .RecordCount
    mycola = .Fields.Count
    mydata = .GetRows()

'now I can loop through my result

Sending Crystal Reports to MAPI

2009-01-30T22:41:00.000-08:00

Dim App as New craxdrt.Application
Dim rpt as craxdrt.Report

Set rpt = App.OpenReport("\\cms_live\Reports\Report Maker
2k1\Admin\ImpBuddyProfile.RPT")

With rpt.ExportOptions
.DestinationType = crEDTEMailMAPI
.FormatType = crEFTPortableDocFormat

.MailToList = "steve"

.MailSubject = "Mail Subject"
.MailMessage = strMessage
End With

With rpt
.DisplayProgressDialog = False
.EnableParameterPrompting = False
.ParameterFields(1).AddCurrentValue "Any Old Value"
.Export False
End With

Finding the position of the first character from a list of characters

2009-01-24T07:30:00.000-08:00

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

    Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

    Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

'Purpose     :  Finds the position of the first character found in a string from a list of characters.
'Inputs      :  sSearchIn           The string to search for the first instance of a character from the character list
'               avChars             The list of characters to search through "sSearchIn" for
'Outputs     :  Returns the position of first instance of a character found in a string from the list of supplied characters,
'               or zero if none of the characters are found
'Example     :  If your wanted to find a line feed, you might use:
'               Debug.Print StringFindFirstChar("ABCDEF","B","E","F")
'               'This would return 2, i.e. the position of character "B"
'Revisions   :

Function StringFindFirstChar(sSearchIn As String, ParamArray avChars() As Variant) As Long
    Dim lPosChar As Long, lPosTest As Long, vChar As Variant
   
    On Error GoTo ErrFailed
    If Len(sSearchIn) Then
        For Each vChar In avChars
            lPosTest = InStr(1, sSearchIn, CStr(vChar))
            If lPosTest Then
                If lPosChar = 0 Then
                    lPosChar = lPosTest
                ElseIf lPosTest < lPosChar Then
                    lPosChar = lPosTest
                End If
            End If
        Next
    End If
    StringFindFirstChar = lPosChar
    Exit Function

ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    'Try the next line
    Resume Next
End Function

Search for a specific string and replace it with another

2009-01-24T07:28:00.000-08:00

Function sReplace(SearchLine as String, SearchFor as String, ReplaceWith as String)
    Dim vSearchLine as String, found as Integer
   
    found = InStr(SearchLine, SearchFor): vSearchLine = SearchLine
    If found <> 0 Then
        vSearchLine = ""
        If found > 1 Then vSearchLine = Left(SearchLine, found - 1)
        vSearchLine = vSearchLine + ReplaceWith
        If found + Len(SearchFor) - 1 < Len(SearchLine) Then _
            vSearchLine = vSearchLine + Right$(SearchLine, Len(SearchLine) - found - Len(SearchFor) + 1)
    end If
    sReplace = vSearchLine
   
End Function

* another routine *


Only 17 lines of code for a super-fast find-and-replace function:

-- start code --

    '  Copy *both* functions to VBScript or VB application:
    '  FindReplace and ReplaceFirstInstance
    '
    Function FindReplace(SourceString, SearchString, ReplaceString)
        tmpString1 = SourceString
        do Until vFixed
            tmpString2 = tmpString1
            tmpString1 = ReplaceFirstInstance(tmpString1, SearchString,ReplaceString)
            If tmpString1 = tmpString2 Then vFixed = True
        Loop
        FindReplace = tmpString1
    end Function

    Function ReplaceFirstInstance(SourceString, SearchString, ReplaceString)
        FoundLoc = InStr(1, SourceString, SearchString)
        If FoundLoc <> 0 Then
            ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
        ReplaceString & Right(SourceString, _
        Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
        Else
            ReplaceFirstInstance = SourceString
        end If
    end Function

--- end code -

 Just to clarify, one function is used to go through the entire string and
replace all instances of the search string ("Replace All").  The other
function is used to only replace the first instance of the search string
("Replace").  The former loops the latter until there are no more instances
of the search string.
>


Function FindReplace(SourceString, searchstring, replacestring)
    tmpString1 = SourceString
    do Until vFixed
        tmpString2 = tmpString1
        tmpString1 = ReplaceFirstInstance(tmpString1, searchstring,
replacestring)
        If tmpString1 = tmpString2 Then vFixed = True
    loop
    FindReplace = tmpString1
End Function

Function ReplaceFirstInstance(SourceString, searchstring, replacestring)
    Static StartLoc '*
    If StartLoc = 0 Then StartLoc = 1 '*
    FoundLoc = InStr(StartLoc, SourceString, searchstring) '*
    If FoundLoc <> 0 Then
            ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
            replacestring & Right(SourceString, _
            Len(SourceString) - (FoundLoc - 1) - Len(searchstring))
            StartLoc = FoundLoc + Len(replacestring) '*
    Else
        StartLoc = 1 '*
        ReplaceFirstInstance = SourceString
    end If
End Function


Return