Public Sub copyFromHyperlink()
Dim rs As DAO.Recordset
Dim strsql As String
Dim docPath As String
Dim destinationPath As String
Dim filePath As String
Dim fileName As String
Dim startPath As String
startPath = CurrentDb.Name
'remove the file name
startPath = Replace(startPath, getFileName(startPath), "")
Debug.Print startPath
destinationPath = "C:\"
strsql = "select fldHyperlink from tblOne"
Set rs = CurrentDb.OpenRecordset(strsql, dbOpenForwardOnly)
Do While Not rs.EOF
If Not IsNull(rs!fldHyperlink) Then
filePath = Application.HyperlinkPart(rs!fldHyperlink, acFullAddress)
If isRelativePath(filePath) Then
filePath = AbsFromRelativePath(startPath, filePath)
End If
fileName = getFileName(filePath)
FileCopy filePath, destinationPath & fileName
Kill filePath
End If
rs.MoveNext
Loop
End Sub
Private Function AbsFromRelativePath(startPath As String _
, relativePath As String) As String
Dim sReturnPath As String
Dim sRelativePath As String
Dim lDirPos As Long
Dim lPathPos As Long
sReturnPath = startPath
If Right$(sReturnPath, 1) = "\" Then 'dump the back slash if there is one
sReturnPath = Left$(sReturnPath, Len(sReturnPath) - 1)
End If
sRelativePath = relativePath
If Left$(sRelativePath, 2) = ".\" Then 'Current folder
sRelativePath = Mid$(sRelativePath, 3)
Else
Do
lDirPos = InStr(1, sRelativePath, "..\")
If lDirPos > 0 Then
sRelativePath = Mid$(sRelativePath, lDirPos + 3)
lPathPos = InStrRev(sReturnPath, "\")
If lPathPos > 0 Then
sReturnPath = Left$(sReturnPath, lPathPos - 1)
Else
Err.Raise 76 'Path not found
End If
End If
Loop While lDirPos > 0
End If
AbsFromRelativePath = sReturnPath & "\" & sRelativePath
End Function
'===================
Public Function isRelativePath(filePath As String) As Boolean
Dim ltr As String
Dim slshCln As String
ltr = UCase(Left(filePath, 1))
slshCln = Mid(filePath, 2, 2)
If Not (Asc(ltr) > 64 And Asc(ltr) < 91 And slshCln = ":\") Then
isRelativePath = True
End If
End Function
Public Function getFileName(filePath As String) As String
Dim sPath As String
Dim sList() As String
Dim sAns As String
Dim iArrayLen As Integer
If Len(filePath) = 0 Then Exit Function
sList = Split(filePath, "\")
iArrayLen = UBound(sList)
If iArrayLen = 0 Then
sAns = ""
Else
sAns = sList(iArrayLen)
End If
getFileName = sAns
End Function