Create a new module and paste this code into it. Call the module basAssociations.
If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' 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 info@codeoftheweek.com
'
' 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
Else
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
Wend
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)
Else
sTemp = Mid$(sItemData, iLastPos, iPos - iLastPos)
End If
Else
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
Else
sNewStr = sNewStr & sTemp & sDest
End If
Wend
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
Else
' grab everything after the .exe
lEXEPos = InStr(1, sEXEFilename, ".exe", vbTextCompare)
FindAssociation = Left$(sEXEFilename, lEXEPos + 3)
End If
Else
Err.Raise 5, "FindAssociation", "Could not locate any application associated with the file " & sFilename
End If
End Function