List in memory

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

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

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

'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

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

'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

'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

'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

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

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

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

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

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

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

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

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

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