Yes I am, I'll have to look at it as this will bring all the file names
and directories in for you into a table. I'll look and see how to
finish it in 2007 access.
Pete,
Thanks for that, I havne't tried it yet, but after reading your
response, I
realised that perhaps I should have mentioned that I am not using
hyperlinks,
but the attachments feature in MS Access 2007. Are you familiar with
it?.
:
This module will do what you need, I assume you only need the file
location/hyperlink. This was not my code to start, I modified it so
you
must keep the author info in the code and revisions out of respect for
those
that share. Pete
'/==========Code starts here================
Option Compare Database
Option Explicit
'created using John Walkenbach's "Microsoft Excel 2000 Power
' Programming with VBA" example as a basic starting point
'====================================
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
'=====================================
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'=====================================
Public Function ListFilesToTable()
On Error Resume Next
'History:
' 07/15/2000 added hyperlink
' 07/17/2000 added filename filter
' 07/20/2000 added # files found info & criteria info
' 07/27/2000 added extension as separate column
' 08/03/2000 changed # files found to 'count' formula
' 10/23/2000 add status bar 'Wait' message
' 04/09/2007 Borrowed code from John Walkenbach's to
' manage USAF vehicle repair manuals in MS Access Pete Duffy
Dim MyDB As Database
Dim MyTable As Recordset
Dim blnSubFolders As Boolean
Dim dblLastRow As Double
Dim i As Integer, r As Integer, x As Integer
Dim Y As Integer ', iWorksheets As Integer Not needed for Access
Dim msg As String, Directory As String, strPath As String
Dim strResultsTableName As String, strFileName As String
Dim strFileNameFilter As String, strDefaultMatch As String
Dim strExtension As String, strFileBoxDesc As String
Dim strMessage_Wait1 As String, strMessage_Wait2 As String
Dim varSubFolders As Variant
Dim strHyperlinkItem As Hyperlink
Dim Files_Found As String
Dim varStatus As Variant
Dim SwitchScreenUpdate As Integer
' I didn't need this for my application
' Dim CalcFileSize As Long
'/==========Variables=============
strResultsTableName = "tbl_LoadHyperLinks" 'Table to store info in
strDefaultMatch = "*.PDF" 'Change to what you want as default
extension
r = 1
i = 1
blnSubFolders = False
strMessage_Wait1 = "Please wait while search is in progress..."
' Access doesn't require formating like original Excel version does.
' strMessage_Wait2 = "Please wait while formatting is completed..."
'/==========Variables=============
strFileNameFilter = InputBox("Ex: *.* with find all files" & vbCr
& _
" blank will find all Office files" & vbCr & _
" *.xls will find all Excel files" & vbCr & _
" G*.doc will find all Word files beginning with G" & vbCr
& _
" Test.txt will find only the files named TEST.TXT" &
vbCr, _
"Enter file name to match:", Default:=strDefaultMatch)
If Len(strFileNameFilter) = 0 Then
strFileBoxDesc = "All MSOffice files"
Else
strFileBoxDesc = strFileNameFilter
End If
msg = "Look for: " & strFileBoxDesc & vbCrLf & _
" - Select location of files to be listed or press Cancel."
Directory = GetDirectory(msg)
If Directory = "" Then Exit Function
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
varSubFolders = _
MsgBox("Search Sub-Folders of " & Directory & " ?", _
vbInformation + vbYesNoCancel, "Search Sub-Folders?")
If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Function
DoCmd.Hourglass True
' Access specific I used a form so user doesn't think computer
frozen
DoCmd.OpenForm "frm_PleaseWait", acNormal, "", "", , acNormal
Forms!frm_PleaseWait.Repaint
r = r + 1
On Error Resume Next
varStatus = SysCmd(acSysCmdSetStatus, strMessage_Wait1)
Set MyDB = CurrentDb
Set MyTable = MyDB.OpenRecordset("tbl_LoadHyperLinks")
With Application.FileSearch
.NewSearch
.LookIn = Directory
'.FileName = "*.*"
.FileName = strFileNameFilter
'.SearchSubFolders = False
.SearchSubFolders = blnSubFolders
.Execute
For i = 1 To .FoundFiles.Count
strFileName = ""
strPath = ""
For Y = Len(.FoundFiles(i)) To 1 Step -1
If Mid(.FoundFiles(i), Y, 1) = "\" Then
Exit For
End If
strFileName = Mid(.FoundFiles(i), Y, 1) & strFileName
Next Y
strPath = Left(.FoundFiles(i), Len(.FoundFiles(i)) -
Len(strFileName))
strExtension = ""
For Y = Len(strFileName) To 1 Step -1
If Mid(strFileName, Y, 1) = "." Then
If Len(strFileName) - Y <> 0 Then
strExtension = Right(strFileName,
Len(strFileName) -
Y)
strFileName = Left(strFileName, Y - 1)
Exit For
End If
End If
Next Y
MyTable.AddNew
MyTable("FileHyperLink") = strPath & strFileName & "#" &
(.FoundFiles(i)) & "##" & "Open Manual " & strFileName _
& " file size is " & FileLen(.FoundFiles(i))
MyTable("FilePath") = strPath
MyTable("FileFilename") = strFileName
MyTable("FileExtension") = strExtension
MyTable("FileSize") = FileLen(.FoundFiles(i))
MyTable("FileDateTime") = FileDateTime(.FoundFiles(i))
MyTable.Update
r = r + 1
SwitchScreenUpdate = SwitchScreenUpdate + 1
If SwitchScreenUpdate = 20 Then
Files_Found = "Writing Record " & r - 1
Forms!frm_PleaseWait.File_Found.Visible = True
Forms!frm_PleaseWait.File_Found.Caption = Files_Found
Forms!frm_PleaseWait.Repaint
SwitchScreenUpdate = 0
End If
Next i
End With
MyTable.Close
Set MyTable = Nothing
Forms!frm_PleaseWait.File_Found.Visible = False
DoCmd.Close acForm, "frm_PleaseWait"
DoCmd.Hourglass False
If Len(strFileNameFilter) = 0 Then
strFileNameFilter = "All MSOffice products"
End If
If blnSubFolders Then
Directory = "(including Subfolders) - " & Directory
End If
Exit_ListFiles:
' Find access equivalent for below.
' Application.StatusBar = False
Exit Function
Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles
End Function
'=======================================
Function GetDirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
'===============End Code=================
Function FileSearcher()
On Error Resume Next
Dim n As Long
Dim SwitchScreenUpdate As Integer
Dim Files_Found As String
With Application.FileSearch
.LookIn = "\Folderpathfilename\"
.FileName = "*.*"
.SearchSubFolders = True
' Need to update, not needed for current application but will
fix
later
' If .Execute(SortBy:=msoSortByFilename,
SortOrder:=msoSortOrderAscending, _
' alwaysAccurate:=True) > 0 Then
' For n = 1 To .FoundFiles.Count
' Worksheets("Sheet1").Cells(n, "A").Value =
..FoundFiles(n)
' varStatus = SysCmd(acSysCmdInitMeter, strStatus,
..FoundFiles(n))
' Next
' End If
End With
End Function
There is Master Field number [Run_no] for each main record that
links to
the
images sub table. But how do I get an update query to link a folder
path
to a
field name? Also, I can't see how the field name works, it just has
a
paperclip icon for each record field in the sub table?
:
On Jul 8, 2:42 am, efandango <
[email protected]>
wrote:
I have a very long list of Images in a single folder that I want
to
attach to
seperate fields in a table/form.
Each record contains two images, which are named like this:
W:\Foldername\Micromap Run 001 A.bmp =(1st record)
W:\Foldername\Micromap Run 001 B.bmp =(1st record)
W:\Foldername\Micromap Run 002 A.bmp =(2nd record)
W:\Foldername\Micromap Run 002 B.bmp =(2nd record)
W:\Foldername\Micromap Run 003 A.bmp =(3rd record)
W:\Foldername\Micromap Run 003 B.bmp =(3rd record)
and so on...
Image A goes to field A
Image B goes to field B
Is there a way of doing this automatically?
The total list of records is 320 (x2 = 640 images)
If there's some kind of rule/algorithm you can use to determine
which
image goes with which record, then it's easy. Just use an update
query.
