Source code for Issue Number 123

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. Source code may not be reproduced except for use in a compiled executable. All rights reserved. If you would like to reprint any or all of this code please email us at

Code of the Week Home

Source Code

Create a new module and paste this code into it. Call the module basAssociations.

If you have any questions, email us at

'   Module Name:    basAssociations
'   Written By:     C&D Programming Corp.
'   Create Date:    2/2000
'   Copyright:      Copyright 2000 by C&D Programming Corp.  Source
'                   code may not be reproduced except for use in a
'                   compiled executable.  All rights reserved.  If
'                   you would like to reprint any or all of this
'                   code please email us at
'   Portions of this issue are derived from previous issues:
'       ReverseInstr
'       ReplaceChars

Private Declare Function FindExecutable Lib "shell32.dll" Alias _
 "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory _
 As String, ByVal lpResult As String) As Long

'   This function works just like Instr, but it searches
'   from the end of the string instead of the beginning
Public Function ReverseInstr(sStringToSearch As String, _
                                sStringToFind As String, _
                                Optional Compare As VbCompareMethod = vbBinaryCompare) As Long

    Dim bDone As Boolean
    Dim lStart As Long
    Dim lLastPos As Long

    lStart = 1
    lLastPos = 0
    bDone = False
    While Not bDone
        lLastPos = InStr(lStart, sStringToSearch, sStringToFind, Compare)
        If lLastPos <> 0 Then
            lStart = lLastPos + 1   ' start searching just past where the string was found
            lLastPos = lStart - 1 ' set the last position sStringToFind was found
            bDone = True        ' we are done since lLastPos was zero which means
                                ' the sStringToFind has no more matches.
        End If
    ReverseInstr = lLastPos
End Function

Public Function ReplaceChars(sItemData As String, sSrc As String, sDest As String) As String
    Dim sNewStr As String
    Dim sTemp As String
    Dim iLastPos As Integer
    Dim iPos As Integer
    Dim iLenSrc As Integer

    iLastPos = 1
    iPos = iLastPos
    iLenSrc = Len(sSrc)
    sNewStr = ""
    sTemp = ""
    While iPos <> 0
        ' Search for occurences of the search string
        iPos = InStr(iLastPos, sItemData, sSrc)
        If iLastPos <> iPos Then
            If iPos = 0 Then
                sTemp = Mid$(sItemData, iLastPos)
                sTemp = Mid$(sItemData, iLastPos, iPos - iLastPos)
            End If
            sTemp = ""
        End If
        ' Position our pointer after the last occurence of
        ' the search string
        iLastPos = iPos + iLenSrc
        ' Build the new string
        If iPos = 0 Then
            sNewStr = sNewStr & sTemp
            sNewStr = sNewStr & sTemp & sDest
        End If
    ReplaceChars = sNewStr
End Function

Public Function FindAssociation(sFilename As String, Optional bWithParams As Boolean = True) As String
    Dim sPath As String
    Dim sFile As String
    Dim lBackSlash As Long
    Dim sEXEFilename As String
    Dim lEXEPos As Long
    Dim lRet As Long

    lBackSlash = ReverseInstr(sFilename, "\")
    If lBackSlash = 0 Then
        Err.Raise 5, "FindAssociation", "You must specify the full path name to the file for locating the association"
    End If

    If Dir(sFilename) = "" Then
        Err.Raise 53, "FindAssociation", "The file " & sFilename & " does not exist.  FindAssociation can only find associations of files that exist."
    End If

    sPath = Left(sFilename, lBackSlash)
    sFile = Mid(sFilename, lBackSlash + 1)
    sEXEFilename = Space$(255)
    lRet = FindExecutable(sFilename, "", sEXEFilename)
    If lRet >= 32 Then
        sEXEFilename = Trim$(ReplaceChars(sEXEFilename, vbNullChar, " "))
        If bWithParams Then
            FindAssociation = sEXEFilename
            ' grab everything after the .exe
            lEXEPos = InStr(1, sEXEFilename, ".exe", vbTextCompare)
            FindAssociation = Left$(sEXEFilename, lEXEPos + 3)
        End If
        Err.Raise 5, "FindAssociation", "Could not locate any application associated with the file " & sFilename
    End If
End Function