Private Sub btnRefreshPicture_Click()
 'Запуск процедуры обновления основного каталога картинок
 On Error GoTo E
               
     'Обновление каталога картинок
    Call RefreshPicture
    
       DoCmd.Close acForm, "msg"
      Exit Sub
E:    MsgBox ("Ошибка " & err.Description)
End Sub

Sub RefreshPicture()
'Процедура поиска новых картинок, перписывания их в служебный каталог
'и записи путей

    Dim strMain As String
    Dim strBuff As String
  'Проверка наличия каталогов, записанных в таблице констант
    
    If PicCatalogExist("Piñ_Main_Catalog") = False Then GoTo E1
    If PicCatalogExist("Pic_Buff_Catalog") = False Then GoTo E1
  
  'Чтение имен файлов из заданного по-умолчанию каталога и запись в temp-
'таблицу
   Call ReadNewPic
   
   'Поиск и пометка новых изображений
   Call FlagNewPic
   
   'Обработка новых данных графических изображений
   Call WritePicData
   
  Exit Sub
E1:  MsgBox ("Подгрузка изображений невозможна" & Chr( 13 ) & "отсутствуют один или оба заданных по-умолчанию каталога")
  Exit Sub
End Sub

Function PicCatalogExist(strConstantName As String) As Boolean
' Проверка наличия каталога
  Dim strCatalog As String
  Dim strFindRezult As String
            
  strCatalog = ReadConstant(strConstantName)
  strFindRezult = Dir(strCatalog, vbDirectory)
   If strFindRezult <> "" Then
   PicCatalogExist = True
   Else
   PicCatalogExist = False
   End If
   
End Function

Sub ReadNewPic()
'Считывание названий файлов и сброс их в темп-таблицу  
  
  Dim strNames() As String
  Dim NameBuffConstant
  Dim strMassage
  Dim i As Long
  Dim j As Long
  Dim strSpisok As String
  
  Dim strDel As String
strDel = "Delete * from tmpNewFiles; "
CurrentDb.Execute strDel
  
  
   Dim strBuffCatalog As String
   
   NameBuffConstant = "Pic_Buff_Catalog"
  
    strBuffCatalog = ReadConstant(NameBuffConstant)
    Dim strFile As String

  strFile = Dir(strBuffCatalog)
  
  i =  1 
Do Until strFile = ""

     ReDim Preserve strNames(i)
     strNames(i) = strFile
      i = i +  1 
    strFile = Dir()
Loop

  Dim rstNewPhoto As DAO.Recordset
  Set rstNewPhoto = CurrentDb.OpenRecordset("tmpNewFiles", dbOpenDynaset)
    rstNewPhoto.AddNew
      strSpisok = ""
      For j =  1  To i -  1 
        rstNewPhoto.AddNew
        rstNewPhoto("FileName") = strNames(j)
        rstNewPhoto("Name") = DelRasshir(strNames(j))
        rstNewPhoto.Update
        strSpisok = strSpisok & "  " & strNames(j)
      Next j
        'MsgBox (strSpisok)
End Sub

Sub FlagNewPic()
'Поиск и пометка новых изображений
Dim strTableName As String
Dim strCompareAtr As String
Dim strCriteria As String
Dim strFK
On Error GoTo E:

 strTableName = ReadConstant("Pic_Base_Table")
 strCompareAtr = ReadConstant("Pic_Compare_Attribute")
 strFK = ReadConstant("Pic_BasePK_Attribute")
 strCriteria = strTableName & "." & strCompareAtr
'tmpNewFiles.Base_FK = [tblMainData]![ID]
 
 Dim strSql
 Dim strSql1
 Dim strFunc As String
 Dim strNumberChar As String

 strFunc = "Right": strNumberChar = "6"
 
  strSql1 = "Select " & strFunc & "([" & strTableName & "]![" & strCompareAtr & "]," & strNumberChar & ")"
 strSql1 = strSql1 & " AS AtrPart"
 strSql1 = strSql1 & " FROM " & strTableName
 
 Dim qdTemp As DAO.QueryDef
 Dim qdfName As String

 qdfName = "tempNumber"
 
 Set qdTemp = CurrentDb.CreateQueryDef(qdfName, strSql1)
 
   qdTemp.Close
   
 
  
      strSql = "UPDATE tmpNewFiles"
      strSql = strSql & " INNER JOIN tempNumber on tmpNewFiles.name="
      strSql = strSql & qdfName & ".AtrPart "
      strSql = strSql & "SET tmpNewFiles.flagNew=true"
      

CurrentDb.Execute strSql
DoCmd.DeleteObject acQuery, qdfName

'SELECT tmpNewFiles.Name FROM cArchive1, tmpNewFiles
'WHERE (((tmpNewFiles.Name)=Right([cArchive1]![cNumber],6)));

Exit Sub
E:
MsgBox ("Ошибка при пометке новых картинок  " & err.Description)
End Sub

Sub WritePicData()

'Тут немного не то, что тебе надо, так как тут обрабатываются только те картинки, имя которых совпадает с тем, что уже есть в базе


Dim strNewFiles As String
strNewFiles = "SELECT tmpNewFiles.FileName, tmpNewFiles.Name, tmpNewFiles.Base_FK FROM tmpNewFiles WHERE (((tmpNewFiles.flagNew)=True));"
Dim strFileName As String
Dim rstNewFiles As DAO.Recordset
Dim lngBaseFK As Long
Set rstNewFiles = CurrentDb.OpenRecordset(strNewFiles, dbOpenDynaset)

Dim strBuffPath As String
Dim strMainPath As String

'
strBuffPath = ReadConstant("Pic_Buff_Catalog")
strMainPath = ReadConstant("Pic_Main_Catalog")


Dim strPathNew As String
Dim strPathBase As String
Dim strFindText As String
Dim lngFK As Long

 If rstNewFiles.EOF <> True Then
   rstNewFiles.MoveFirst
   Do Until rstNewFiles.EOF
   
   
       strFileName = rstNewFiles!Filename
   
    strPathNew = strBuffPath & strFileName
    strPathBase = strMainPath & strFileName

    FileCopy strPathNew, strPathBase

      
      '!!!!!!!!!!
      strFindText = Dir(strPathBase)

      If strFindText = "" Then GoTo E1
            
     
      Kill strPathNew
           
E1:   rstNewFiles.MoveNext
   Loop
  
 End If
Dim strDel As String
strDel = "Delete * from tmpNewFiles; "
CurrentDb.Execute strDel
End Sub