Stuart McCall's Microsoft Access Pages - Strings

Home
Append Item to delimiter-separated list

Public Sub ListAddItem(List$, ByVal Item$, Optional Delimiter = ",", Optional Unique As Boolean)
'Appends Item to List.
'If Unique is True, prevents duplicate entries
    If Unique And InStr(1, List & Delimiter, Item & Delimiter) > 0 Then Exit Sub
    If List <> "" Then List = List & Delimiter
    List = List & Item
End Sub
Paste this function into a standard module.
Home Contents
Insert Item into delimiter-separated list at index [n]

Public Sub ListInsertItem(List$, ByVal Item$, idx&, Optional Delimiter = ",")
'Inserts Item into List at element index idx
    Dim i As Long, ix As Long, a As Variant
    
    ix = idx - 1
    ListAddItem List, "*", Delimiter
    a = Split(List, Delimiter)
    For i = UBound(a) To ix + 1 Step -1
        a(i) = a(i - 1)
    Next
    a(ix) = Item
    List = Join(a, Delimiter)
    Erase a
End Sub
Paste this function into a standard module.
Home Contents
Edit Item in delimiter-separated list at index [n]

Public Sub ListEditItem(List$, ByVal idx&, ByVal Value$, Optional Delimiter = ",")
'Edits the Item at element index idx
    Dim ix As Long, a As Variant
    
    ix = idx - 1
    a = Split(List, Delimiter)
    a(ix) = Item
    List = Join(a, Delimiter)
    Erase a
End Sub
Paste this function into a standard module.
Home Contents
Delete Item from delimiter-separated list at index [n]

Public Sub ListDelItem(List$, idx&, Optional Delimiter = ",")
'Deletes the Item at element index idx
    Dim i As Long, ix As Long, a As Variant, t As String

    ix = idx - 1
    a = Split(List, Delimiter)
    For i = ix To UBound(a) - 1
        a(i) = a(i + 1)
    Next
    a(i) = ""
    t = Join(a, Delimiter)
    List = Left$(t, Len(t) - 1)
    Erase a
End Sub
Paste this function into a standard module.
Home Contents
Sort Items in a delimiter-separated list

Public Sub ListSort(List$, Optional Delimiter = ",")
'Sorts the List
    Dim a As Variant, l As Long, r As Long, s As Long
    
    a = Split(List, Delimiter)
    l = UBound(a)
    For r = LBound(a) To l
        s = r
        For i = r + 1 To l
            If a(i) < a(s) Then
                s = i
            End If
        Next
        If s > r Then
            t = a(r)
            a(r) = a(s)
            a(s) = t
        End If
    Next
    List = Join(a, Delimiter)
    Erase a
End Sub
Paste this function into a standard module.
Home Contents
Obtain the element index of an Item a delimiter-separated list

Public Function ListItemIndex(List$, ByVal Item$, Optional Delimiter = ",") As Long
Returns the element index of Item
    Dim a As Variant, i As Long
    
    a = Split(List, Delimiter)
    For i = LBound(a) To UBound(a)
        If a(i) = Item Then
            ListItemIndex = i + 1
            Exit For
        End If
    Next
    Erase a
End Function
Paste this function into a standard module.
Home Contents
Obtain an Item from a delimiter-separated list at element index [n]

Public Function ListItem(List$, idx&, Optional Delimiter = ",") As String
'Returns the Item at element index idx
    ListItem = Split(List, Delimiter)(idx - 1)
End Function
Paste this function into a standard module.
Home Contents
Determine the number of elements in a delimiter-separated list

Public Function ListItemCount(List$, Optional Delimiter = ",") As Long
'Returns the element count
    ListItemCount = UBound(Split(List, Delimiter)) + 1
End Function
Paste this function into a standard module.
Home Contents
All the delimited list functions as a complete Module

Option Compare Database
Option Explicit

Public Sub ListAddItem(List$, ByVal Item$, Optional Delimiter = ",", Optional Unique As Boolean)
'Appends Item to List.
'If Unique is True, prevents duplicate entries
    If Unique And InStr(1, List & Delimiter, Item & Delimiter) > 0 Then Exit Sub
    If List <> "" Then List = List & Delimiter
    List = List & Item
End Sub

Public Sub ListInsertItem(List$, ByVal Item$, idx&, Optional Delimiter = ",")
'Inserts Item into List at element index idx
    Dim i As Long, ix As Long, a As Variant
    
    ix = idx - 1
    ListAddItem List, "*", Delimiter
    a = Split(List, Delimiter)
    For i = UBound(a) To ix + 1 Step -1
        a(i) = a(i - 1)
    Next
    a(ix) = Item
    List = Join(a, Delimiter)
    Erase a
End Sub

Public Sub ListEditItem(List$, ByVal idx&, ByVal Value$, Optional Delimiter = ",")
'Edits the Item at element index idx
    Dim ix As Long, a As Variant
    
    ix = idx - 1
    a = Split(List, Delimiter)
    a(ix) = Item
    List = Join(a, Delimiter)
    Erase a
End Sub

Public Sub ListDelItem(List$, idx&, Optional Delimiter = ",")
'Deletes the Item at element index idx
    Dim i As Long, ix As Long, a As Variant, t As String

    ix = idx - 1
    a = Split(List, Delimiter)
    For i = ix To UBound(a) - 1
        a(i) = a(i + 1)
    Next
    a(i) = ""
    t = Join(a, Delimiter)
    List = Left$(t, Len(t) - 1)
    Erase a
End Sub

Public Sub ListSort(List$, Optional Delimiter = ",")
'Sorts the List
    Dim a As Variant, l As Long, r As Long, s As Long
    
    a = Split(List, Delimiter)
    l = UBound(a)
    For r = LBound(a) To l
        s = r
        For i = r + 1 To l
            If a(i) < a(s) Then
                s = i
            End If
        Next
        If s > r Then
            t = a(r)
            a(r) = a(s)
            a(s) = t
        End If
    Next
    List = Join(a, Delimiter)
    Erase a
End Sub

Public Function ListItemIndex(List$, ByVal Item$, Optional Delimiter = ",") As Long
Returns the element index of Item
    Dim a As Variant, i As Long
    
    a = Split(List, Delimiter)
    For i = LBound(a) To UBound(a)
        If a(i) = Item Then
            ListItemIndex = i + 1
            Exit For
        End If
    Next
    Erase a
End Function

Public Function ListItem(List$, idx&, Optional Delimiter = ",") As String
'Returns the Item at element index idx
    ListItem = Split(List, Delimiter)(idx - 1)
End Function

Public Function ListItemCount(List$, Optional Delimiter = ",") As Long
'Returns the element count
    ListItemCount = UBound(Split(List, Delimiter)) + 1
End Function
Paste all of this into an empty, standard module.
Home Contents
Functions for use with file paths

Public Function DrivePart(ByVal FullPath$) As String
' Returns the Drive only from a fully qualified filename
    DrivePart = Left$(FullPath, 2)
End Function

Public Function PathPart(ByVal FullPath$) As String
' Returns the path only from a fully qualified filename
    PathPart = Left$(FullPath, InStrRev(FullPath, "\"))
End Function

Public Function FilePart(ByVal FullPath$) As String
' Returns the filename only from a fully qualified filename
    FilePart = Mid$(FullPath, Len(PathPart(FullPath)) + 1)
End Function

Public Function FileNamePart(ByVal FullPath$) As String
' Returns the filename only (no extension) from a fully qualified filename
    Dim t As String
    t = FilePart(FullPath)
    FileNamePart = Left$(t, InStrRev(t, ".") - 1)
End Function

Public Function ExtensionPart(ByVal FullPath$) As String
' Returns the extension only from a fully qualified filename
    ExtensionPart = Mid$(FullPath, InStrRev(FullPath, ".") + 1)
End Function

Public Function DbPath() As String
' Returns the current db's path (includes trailing \)
    DbPath = PathPart(CurrentDb.Name)
End Function

Public Function IsPath(ByVal Path As String) As Boolean
' Returns True if path exists
    IsPath = (Len(Dir$(Path, vbDirectory)) > 0)
End Function

Public Function AddSlash(ByVal Path$) As String
' Ensures path$ is terminated with a slash
    If Right$(Path, 1) <> "\" Then
        Path = Path & "\"
    End If
    AddSlash = Path
End Function

Public Function NoSlash(ByVal Path$) As String
' Ensures path$ is not terminated with a slash
    If Right$(Path, 1) = "\" Then
        Path = Left$(Path, Len(Path) - 1)
    End If
    NoSlash = Path
End Function
Paste all of this into an empty, standard module.
Home Contents
Create complete path if it doesn't already exist

Public Function CreatePath(ByVal pstrPath As String) As Long
' Creates complete path pstrPath if it doesn't already exist
' Returns 0 for success, or error number
' Accepts 'normal' (DOS) or UNC paths
'
' eg: ErrNum = CreatePath("c:\access\newpath")
'
' or: ErrNum = CreatePath("\\server\share\access\newpath")
'
'Requires: IsPath function (included below)

    Const SLASH As String = "\"
    Const TWOSLASH As String = "\\"
    
    Dim i As Integer, j As Integer
    Dim strBuild As String
    
    On Error GoTo CreatePath_Err
    
    ' Bail out now if path already exists
    If IsPath(pstrPath) Then Exit Function
    'Ensure path is terminated properly
    If Right$(pstrPath, 1) <> SLASH Then pstrPath = pstrPath & SLASH
    
    'Find starting point
    If InStr(1, pstrPath, ":") = 2 Then
        'Normal path
        j = 4
    ElseIf InStr(1, pstrPath, TWOSLASH) = 1 Then
        'UNC path
        j = InStr(3, pstrPath, SLASH) + 1   'Skip server name
        j = InStr(j, pstrPath, SLASH) + 1   'Skip share name
    Else
        'Illegal path - return 'Path/file access error'
        Err.Raise 75
    End If
    'Start accumulating
    strBuild = Left$(pstrPath, j - 1)
    
    Do
        i = InStr(j, pstrPath, SLASH)
        'Bail out if no more slashes
        If i = 0 Then Exit Do
        'Accumulate next part of path
        strBuild = strBuild & Mid$(pstrPath, j, i - j)
        'If it doesn't already exist
        If Not IsPath(strBuild) Then
            'Create it
            MkDir strBuild
        End If
        strBuild = strBuild & SLASH
        j = i + 1
    Loop

CreatePath_Exit:
    Exit Function

CreatePath_Err:
    'Return error
    CreatePath = Err.Number
    Resume CreatePath_Exit

End Function

Public Function IsPath(ByVal Path As String) As Boolean
' Returns True if path exists
    IsPath = (Len(Dir$(Path, vbDirectory)) > 0)
End Function
Paste this Code into a standard module.
Home Contents
Obtain a file's short (8.3) filename from it's long filename

Private Declare Function GetShortPathNameA Lib "Kernel32" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Paste these Declarations into the top of a standard module (ie before any procedures). 
Function ShortPath(ByVal pstrPath As String) As String
' Returns the short DOS path from a LFN path
    Dim buffer As String * 255
    Dim fLen As Long
    
    fLen = GetShortPathNameA(pstrPath, buffer, 255&)
    ShortPath = Left(buffer, fLen)
End Function
Paste this Code into the same module.
Usage: 
Debug.Print ShortPath("C:\Program Files\Outlook Express\msoe.txt")

Result: C:\PROGRA~1\OUTLOO~1\msoe.txt
Home Contents
Obtain a file path from a Special Folder location

Public Enum sfTarget
   CSIDL_DESKTOP = &H0                   '(desktop)
   CSIDL_INTERNET = &H1                  'Internet Explorer (icon on desktop)
   CSIDL_PROGRAMS = &H2                  'Start Menu\Programs
   CSIDL_CONTROLS = &H3                  'My Computer\Control Panel
   CSIDL_PRINTERS = &H4                  'My Computer\Printers
   CSIDL_PERSONAL = &H5                  'My Documents
   CSIDL_FAVORITES = &H6                 '(user name)\Favorites
   CSIDL_STARTUP = &H7                   'Start Menu\Programs\Startup
   CSIDL_RECENT = &H8                    '(user name)\Recent
   CSIDL_SENDTO = &H9                    '(user name)\SendTo
   CSIDL_BITBUCKET = &HA                 '(desktop)\Recycle Bin
   CSIDL_STARTMENU = &HB                 '(user name)\Start Menu
   CSIDL_DESKTOPDIRECTORY = &H10         '(user name)\Desktop
   CSIDL_DRIVES = &H11                   'My Computer
   CSIDL_NETWORK = &H12                  'Network Neighborhood
   CSIDL_NETHOOD = &H13                  '(user name)\nethood
   CSIDL_FONTS = &H14                    'windows\fonts
   CSIDL_TEMPLATES = &H15                '(user name)\Templates
   CSIDL_COMMON_STARTMENU = &H16         'All Users\Start Menu
   CSIDL_COMMON_PROGRAMS = &H17          'All Users\Programs
   CSIDL_COMMON_STARTUP = &H18           'All Users\Startup
   CSIDL_COMMON_DESKTOPDIRECTORY = &H19  'All Users\Desktop
   CSIDL_APPDATA = &H1A                  '(user name)\Application Data
   CSIDL_PRINTHOOD = &H1B                '(user name)\PrintHood
   CSIDL_LOCAL_APPDATA = &H1C            '(user name)\Local Settings\Application Data (non roaming)
   CSIDL_ALTSTARTUP = &H1D               'non localized startup
   CSIDL_COMMON_ALTSTARTUP = &H1E        'non localized common startup
   CSIDL_COMMON_FAVORITES = &H1F         'All Users\favorites
   CSIDL_INTERNET_CACHE = &H20           'Internet Explorer cache
   CSIDL_COOKIES = &H21                  'Internet Explorer cookie files
   CSIDL_HISTORY = &H22                  'Internet Explorer history data
   CSIDL_COMMON_APPDATA = &H23           'All Users\Application Data
   CSIDL_WINDOWS = &H24                  'GetWindowsDirectory()
   CSIDL_SYSTEM = &H25                   'GetSystemDirectory()
   CSIDL_PROGRAM_FILES = &H26            'C:\Program Files
   CSIDL_MYPICTURES = &H27               'My Documents\My Pictures
   CSIDL_PROFILE = &H28                  'User Profile
   CSIDL_PROGRAM_FILES_COMMON = &H2B     'C:\Program Files\Common
   CSIDL_COMMON_TEMPLATES = &H2D         'All Users\Templates
   CSIDL_COMMON_DOCUMENTS = &H2E         'All Users\Documents
   CSIDL_COMMON_ADMINTOOLS = &H2F        'All Users\Start Menu\Programs\Administrative Tools
   CSIDL_ADMINTOOLS = &H30               '(user name)\Start Menu\Programs\Administrative Tools

   CSIDL_FLAG_CREATE = &H8000            'combine with CSIDL_ value to force create on SHGetSpecialFolderLocation()
   CSIDL_FLAG_DONT_VERIFY = &H4000       'combine with CSIDL_ value to force create on SHGetSpecialFolderLocation()
   CSIDL_FLAG_MASK = &HFF00              'mask for all possible flag values
End Enum
'
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
'
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type
'
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Paste these Declarations into the top of a standard module (ie before any procedures). 
Public Function SpecialFolder(Target As sfTarget) As String
    Dim IDL As ITEMIDLIST, Path$
    '
    If SHGetSpecialFolderLocation(100&, Target, IDL) = 0 Then
        Path = Space$(512)
        SHGetPathFromIDList ByVal IDL.mkid.cb, ByVal Path
        SpecialFolder = Left$(Path, Instr(1, Path, vbNullChar) - 1)
    End If
End Function
Paste this Code into the same module.
Usage: 
Debug.Print SpecialFolder(CSIDL_FONTS)

Result: C:\WINDOWS\Fonts
Home Contents
Obtain the Windows and System folders

Private Declare Function GetWindowsDirectoryA Lib "Kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectoryA Lib "Kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Paste these Declarations into the top of a standard module (ie before any procedures). 
Public Function WindowsDir() As String
    Dim buf As String * 255, l&
    l = GetWindowsDirectoryA(buf, 254&)
    If l Then WindowsDir = Left$(buf, l) & "\"
End Function

Public Function SystemDir() As String
    Dim buf As String * 255, l&
    l = GetSystemDirectoryA(buf, 254&)
    If l Then SystemDir = Left$(buf, l) & "\"
End Function
Paste this Code into the same module.
Usage: 
Debug.Print SystemDir()

Result: C:\WINDOWS\system32\
Home Contents
Add/Remove brackets [.] to/from a field name

Public Function Bracketed(ByVal s$) As String
    If Asc(s) <> 91 Then
        s = "[" & s & "]"
        s = Replace(s, ".", "].[")
    End If
    Bracketed = s
End Function

Public Function UnBracket(ByVal s$) As String
    s = Replace(s, "[", "")
    s = Replace(s, "]", "")
    UnBracket = Replace(s, "].[", ".")
End Function
Paste this Code into a standard module.
Usage: 
Debug.Print Bracketed("TableName.Field1")

Result: [TableName].[Field1]

Debug.Print UnBracket("[TableName].[Field1]")

Result: TableName.Field1
Home Contents
Sort a string array

Public Sub SortArray(Item$())
    Dim lastItem&, SmallestRow&, row&, i&, tmp$
    
    lastItem = UBound(Item)
    For row = 1 To lastItem
        SmallestRow = row
        For i = row + 1 To lastItem
            If Item(i) < Item(SmallestRow) Then
                SmallestRow = i
            End If
        Next
        '
        If SmallestRow > row Then
            tmp = Item(row)
            Item(row) = Item(SmallestRow)
            Item(SmallestRow) = tmp
        End If
    Next
End Sub
Paste this Code into a standard module.
Usage: 
ReDim a(1 To 3) As String, i&
a(1) = "Oranges"
a(2) = "Apples"
a(3) = "Pears
SortArray a
For i = Lbound(a) To Ubound(a)
    Debug.Print a(i)
Next

Result:

Apples
Oranges
Pears
Home Contents
Text block sans blank rows

Public Function ShrinkLines(ParamArray values()) As String
'Returns a formatted text block from separate values.
'Null or zero-length values are stripped out.
'
'eg: Debug.Print ShrinkLines([Field1], [Field2], [Field3])
'
'If Field1 contains 'Stuart', Field2 is Null, and Field3
'contains 'McCall', the result would be:
'
'Stuart
'McCall
    Dim v As Variant, r As String
    
    For Each v In values
        If Len(v & "") > 0 Then
            r = r & v & vbcrlf
        End If
    Next
    ShrinkLines = r
End Function
Paste this Code into a standard module.
Home Contents
Replace ordinal tokens in a string

Public Function nReplace(Template, ParamArray Values()) As String
    Dim i&, s$
    s = Template
    For i = LBound(Values) To UBound(Values)
        s = Replace(s, "%" & i + 1, Values(i))
    Next
    nReplace = s
End Function
Paste this Code into a standard module.

Usage:

Const ConnectTemplate = "DBQ=%1;DSN=%2;UID=%3;PWD=%4;DESCRIPTION=%5;DIR=%6"
Dim s As String
s = nReplace(ConnectTemplate, Database, DSN, UserID, Password, Description, Path)
Debug.Print s
Home Contents
Replace item/value pairs in a string

Public Function ReplaceList(ByVal Template$, ParamArray ItemValuePairs()) As String
    Dim i&
    For i = LBound(ItemValuePairs) To UBound(ItemValuePairs) Step 2
        Template = Replace(Template, ItemValuePairs(i), ItemValuePairs(i + 1))
    Next
    ReplaceList = Template
End Function
Paste this Code into a standard module.

Usage:

Const ConnectTemplate = "DBQ=<DBQ>;DSN=<DSN>;UID=<UID>;PWD=<PWD>;DESCRIPTION=<DESC>;DIR=<DIR>"
Dim s As String
s = ReplaceList(ConnectTemplate, "<DBQ>", Database, "<DSN>", DSN, "<UID>", UserID, _
                "<PWD>", Password, "<DESC>", Description, "<DIR>", Path)
Debug.Print s
Home Contents
Format values correctly for use in criteria

Public Function Cv(Value, Num_Text_or_Date As String) As Variant
'CriteriaValue - correctly quote Value
'for use as a criteria string

'The Num_Text_or_Date parameter accepts:
' N, Num or Number for Boolean,Byte,Integer,Long,Currency,Single,Double
' T, Text or String for Text, Memo
' D or Date for Date/Time
    If Not IsNull(Value) Then
        Select Case Num_Text_or_Date
            Case "N", "Num", "Number"
                Cv = Value
            Case "T", "Text", "String"
                Cv = Chr(34) & Replace(Value, "'", "''") & Chr(34)
            Case "D", "Date"
                Cv = "#" & Format(Value, "mm/dd/yyyy") & "#"
            Case Else
                MsgBox "Unrecognised data type passed", vbExclamation
        End Select
    End If
End Function
Paste this Code into a standard module.

Usage:

'Given a form containing 2 controls: DateControl & TextControl,
'DateControl contains 1/1/08 and TextControl contains Stuart's code

Dim SQL As String

SQL = "SELECT * FROM tblCustomers WHERE DateField = " & Cv(DateControl, "D")
SQL = SQL & " AND TextField = " & Cv(TextControl, "T")
Debug.Print SQL

Result:

SELECT * FROM tblCustomers WHERE DateField = #01/01/2008# AND TextField = "Stuart''s code"
Home Contents
Delete all files from a folder tree, leaving the folders in place

Public Sub EmptyFolderTree(ByVal Path As String)
    Dim s As String
    Dim thisFdr As String
    Dim fdrList As New Collection
    
    If Right$(Path, 1) <> "\" Then Path = Path & "\"
    fdrList.Add Path
    Do While fdrList.Count
        'remove this folder from folder list
        thisFdr = fdrList.item(1)
        fdrList.Remove 1
        'find all files and folders in current & add to list
        s = Dir$(thisFdr, vbDirectory)
        Do While Len(s)
            If Asc(s) <> 46 Then 'Exclude "." and ".."
                If GetAttr(thisFdr & s) = vbDirectory Then
                    fdrList.Add thisFdr & s & "\" 'add the folder
                Else
                    Kill thisFdr & s
                End If
            End If
            s = Dir$
        Loop
    Loop
End Sub
Paste this Code into a standard module.
Home Contents