Mange image files with code

[MM]

I have an access db that I use to manage the updates and maintenece
of our SQL based web data. One of the functions is to update the
filed
to note when we have a product image.With some help several years ago
from this group I was able to get the following code to work. This
code looks at all th eimage files in a folder against the product
code
in inventory table and if a match is found it adds the needed
filename
detail to a field.

Over the years the images have build up and I'd like to delete the
image files that exist were there is no matching inventory item any
more.


Suggestions/


Public Function ImageTest()


''
'' GET FILE NAMES FROM FOLDER
''
Dim sFileDir As String
Dim rsFileInfo As ADODB.Recordset
Set rsFileInfo = New ADODB.Recordset


' create the filename field -- this is a string data type, length
255
rsFileInfo.Fields.Append "FileName", adBSTR, 255


' open the recordset
rsFileInfpen


' get the files in the correct directory
sFileDir = Dir("i:\*.jpg") ' change the path as necessary


Do While sFileDir <> ""
If sFileDir <> "." And sFileDir <> ".." Then
rsFileInfo.AddNew
' rsFileInfo!FileName = sFileDir
' use the next line instead to get the file name
' minus the last four characters ".jpg"
rsFileInfo!FileName = Left(sFileDir, Len(sFileDir)
-
4)
rsFileInfo.Update
Debug.Print rsFileInfo!FileName
' get the next file in the directory
sFileDir = Dir
End If
Loop
rsFileInfo.MoveFirst


''
'' COMPARE FILES TO RECORDS IN INVENTORY
''
Dim rsInv As ADODB.Recordset
Set rsInv = New ADODB.Recordset
rsInv.ActiveConnection = CurrentProject.Connection
' open recordset of all inventory records
rsInv.Open "SELECT * FROM Inventory WHERE
(((Inventory.ProdCode)is
not null));", , adOpenKeyset, adLockOptimistic
' loop thru recordset to find matches in rsFileInfo
Do Until rsInv.EOF
Do Until rsFileInfo.EOF
' we've taken out the ".jpg" from the filename
If rsInv!ProdCode = rsFileInfo!FileName Then
rsInv!PathToImagesFolder = rsFileInfo!FileName & ".jpg"
End If
rsFileInfo.MoveNext
Loop
rsFileInfo.MoveFirst
rsInv.MoveNext
Loop
rsFileInfo.Close
rsInv.Close
Set rsFileInfo = Nothing
Set rsInv = Nothing


End Function


Thanks in advance,
MM

 

[Pieter Wijnen]

A slight modification of your code to "link" should do

Dim Db As DAO.Database
Dim Rs As DAO.Recordset
Dim FName As String

Set Db = Access.CurrentDb
Set Rs = Db.OpenRecordset("SELECT MyImage FROM
Inventory",DAO.dbOpenSnapshot)

Fname = VBA.Dir("MyPath\*.jpg")
While VBA.Len(FName)
Rs.FindFirst "Myimage Like '*" & Rs.Fields("MyImage").Value & "'"
IF Rs.NoMatch Then
VBA.Kill "MyPath\" & FName
' Consider using Name instead to move the files to another location
End If
Fname = Dir()
Wend
Rs.Close : Set Rs = Nothing
Set Db = Nothing

Exchange MyImage & MyPath as required

HtH

Pieter