Автрматическая загрузка фото в таблицы с полем вложение

@Spec_0994 · Регистрация: 01.11.2016

Студворк — интернет-сервис помощи студентам

Всем Привет.Нужна помощь.Есть огромное количество фотографий порядка 20 тысяч, их нужно загрузить в базу. Они ужаты максимально и в полном обьеме составляют не больше 150мб. Есть поле ln где написан каждый id и есть в папке фотографии которые подписаны как id.png. На фото видно фотки и видно поля в таблицы, они совпадают. Подскажите как их можно все загрузить в нужные строки в вложение в таблице?

@Eugene-LS · 08.12.2016, 01:44

Сообщение от Spec_0994

Подскажите как их можно все загрузить в нужные строки в вложение в таблице?

Лучше не хранить в базе - а подключать.
Вот вариант:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
'--------------------------------------------------------------------
' Module    : clsPictureData
' Author    : Бенедикт
' Purpose   : загружает файл в Image либо через .Picture, либо через .PictureData
'             в последнем случае используется метафайл
'--------------------------------------------------------------------
' Требуется библ. ссылка на OLE Automation
'--------------------------------------------------------------------
' По материалам: [url]http://www.sql.ru/forum/actualthread.aspx?tid=304849[/url]
 
Option Compare Database
Option Explicit
 
'----------- Описания структур, функций, констант Win32 API ---------
 
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
 
Private Type BITMAP '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type
 
Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetObjectA Lib "gdi32" ( _
   ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
 
Private Declare Function GetObjectType Lib "gdi32" ( _
   ByVal hgdiobj As Long) As Long
Private Const OBJ_BITMAP = 7
 
Private Declare Function GetDC Lib "user32" ( _
   ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
   ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const HORZSIZE = 4           '  Horizontal size in millimeters
Private Const VERTSIZE = 6           '  Vertical size in millimeters
Private Const HORZRES = 8            '  Horizontal width in pixels
Private Const VERTRES = 10           '  Vertical width in pixels
 
Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" ( _
   ByVal hEMF As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Any) As Long
 
Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As Long) As Long
Private Const MM_ANISOTROPIC = 8 ' Map mode anisotropic
 
Private Declare Function SetWindowExtExAny Lib "gdi32" _
   Alias "SetWindowExtEx" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As Long
Private Declare Function SetViewportExtExAny Lib "gdi32" _
   Alias "SetViewportExtEx" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As Long
 
Private Declare Function SetStretchBltMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Const STRETCH_DELETESCANS = 3
Private Const STRETCH_HALFTONE = 4
 
Private Declare Function BitBlt Lib "gdi32" ( _
   ByVal hdcDest As Long, ByVal x As Long, ByVal y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, _
   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Destination As Any, Source As Any, ByVal Length As Long)
 
Private Const CF_ENHMETAFILE = 14
'-------------------------------------------------------------------------------
 
Private m_hEMF As Long
 
 
Public Function Load(ByVal FileName As String, Image As Image) As Boolean
Dim pic As StdPicture
Dim rc As RECT
Dim hdcRef As Long
Dim hdcMeta As Long
Dim hdcMem As Long
Dim bm As BITMAP
Dim cbSize As Long
Dim cbCopied As Long
Dim hbmpOld As Long
Dim iWidthMM As Long
Dim iHeightMM As Long
Dim iWidthPels As Long
Dim iHeightPels As Long
Dim nDotPos As Integer
 
ReleaseResources
 
'Выделение расширения имени файла, принятие решения, идти по длинному пути
'или по короткому.
    FileName = Trim$(FileName)
    nDotPos = InStrRev(FileName, ".")
    If nDotPos > InStrRev(FileName, "") Then
        Select Case UCase$(Mid$(FileName, nDotPos + 1))
        Case "WMF", "EMF", "ICO", "BMP", "DIB":
           'Если хотим пользоваться STRETCH_HALFTONE (см. ниже),
           'то BMP и DIB из списка убрать.
           'Считаем, что окно фильтра для простых форматов не появляется,
           'грузим изображение через свойство Picture.
           On Error Resume Next
           Image.Picture = FileName
           Load = Err = 0
           On Error GoTo 0
           Exit Function
        End Select
    End If
 
'До конца функции - загрузка изображения через свойство PictureData.
    On Error Resume Next
    Set pic = LoadPicture(FileName)
    On Error GoTo 0
    If pic Is Nothing Then
        'Ещё попытка - для форматов типа PNG, PCX, TGA, не понимаемых LoadPicture
        On Error Resume Next
        Image.Picture = FileName
        Load = Err = 0
        On Error GoTo 0
        Exit Function
    End If
 
'Ожидается pic.Type=vbPicTypeBitmap=1,GetObjectType(pic.Handle)=OBJ_BITMAP=7
    If GetObjectType(pic.Handle) <> OBJ_BITMAP Then Exit Function
 
'Получаем заголовок битмапа, чтобы извлечь из него размеры изображения
'в пикселях
    cbSize = LenB(bm)
    cbCopied = GetObjectA(pic.Handle, cbSize, bm)
    If cbCopied <> cbSize Then Exit Function
 
'Считаем, что Image.Parent.hWnd - дескриптор окна формы
    hdcRef = GetDC(Image.Parent.hWnd)
    
    iWidthMM = GetDeviceCaps(hdcRef, HORZSIZE)
    iHeightMM = GetDeviceCaps(hdcRef, VERTSIZE)
    iWidthPels = GetDeviceCaps(hdcRef, HORZRES)
    iHeightPels = GetDeviceCaps(hdcRef, VERTRES)
    
    rc.Right = bm.bmWidth * iWidthMM * 100 / iWidthPels
    rc.Bottom = bm.bmHeight * iHeightMM * 100 / iHeightPels
 
'Создаём "усовершенствованный" метафайл в памяти
    hdcMeta = CreateEnhMetaFile(hdcRef, vbNullString, rc, vbNullString)
 
    If hdcMeta = 0 Then
        ReleaseDC Image.Parent.hWnd, hdcRef
        Exit Function
    End If
    
    SetMapMode hdcMeta, MM_ANISOTROPIC
    SetWindowExtExAny hdcMeta, bm.bmWidth, bm.bmHeight, ByVal 0&
    SetViewportExtExAny hdcMeta, bm.bmWidth, bm.bmHeight, ByVal 0&
'Access с целью совместимости с Win9x использует режим STRETCH_DELETESCANS,
'он быстрее, но менее качественный, чем STRETCH_HALFTONE. Последний доступен
'в NT/200x/XP.
    SetStretchBltMode hdcMeta, STRETCH_HALFTONE 'STRETCH_DELETESCANS
    
    hdcMem = CreateCompatibleDC(hdcRef)
    hbmpOld = SelectObject(hdcMem, pic.Handle)
    
    BitBlt hdcMeta, 0, 0, bm.bmWidth, bm.bmHeight, hdcMem, 0, 0, SRCCOPY
    
    SelectObject hdcMem, hbmpOld
    DeleteDC hdcMem
    ReleaseDC Image.Parent.hWnd, hdcRef
    Set pic = Nothing 'освобождаем память
    
    m_hEMF = CloseEnhMetaFile(hdcMeta)
    If m_hEMF = 0 Then Exit Function
    
    cbSize = GetEnhMetaFileBits(m_hEMF, 0, ByVal 0&)
    ReDim bPicData(0 To cbSize + 7) As Byte
    cbCopied = GetEnhMetaFileBits(m_hEMF, cbSize, bPicData(8))
    
    bPicData(0) = CF_ENHMETAFILE
    CopyMemory bPicData(4), m_hEMF, 4 'хотя можно и побайтно заполнить
    Image.PictureData = bPicData
    Erase bPicData 'освобождаем память
    
    Load = True
End Function
Private Sub ReleaseResources()
    If m_hEMF Then
        DeleteEnhMetaFile m_hEMF
        m_hEMF = 0
    End If
End Sub
 
Private Sub Class_Terminate()
    ReleaseResources
End Sub

Пример использования в форме (Обьект Picture = Me!Im_Picture)

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Private Sub PictuereUPD()
' Загрузка изображения в обьект Picture : Me!Im_Picture
'--------------------------------------------------------------------
Dim pd As clsPictureData
Dim strPath As String
 
On Error GoTo PictuereUPD_Err
    
    Set pd = New clsPictureData
    
    If Not IsNull(Me!txtFileName) Then
        ' Получаем полный путь
        strPath = CurrentProject.Path & "" & Me!txtFileName
        ' вписываем Полный путь в поле (чисто для наглядности)
        Me!txtFilePath = strPath
        ' Загрузка
        If pd.Load(strPath, Me!Im_Picture) Then
           If Not Me!Im_Picture.Visible Then Me!Im_Picture.Visible = True
        Else
           If Me!Im_Picture.Visible Then Me!Im_Picture.Visible = False
        End If
    Else 'Не указано или новая запись
        Me!txtFilePath = Null
        Me!Im_Picture.Visible = False
    End If
 
PictuereUPD_Bye:
    Set pd = Nothing
    Exit Sub
 
PictuereUPD_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure PictuereUPD", vbCritical, "Error!"
    Resume PictuereUPD_Bye
End Sub
 
Private Sub cmdUPD_Click()
'Кнопка "Обновить!" (изображение)
    PictuereUPD
End Sub
 
Private Sub Form_Current()
'Переход на тек запись
    PictuereUPD
End Sub

И пример ...

@Eugene-LS · 08.12.2016, 01:55

Сообщение от Spec_0994

все загрузить в нужные строки в вложение в таблице?

Если уж совсем надо - Вот вариант с хранением файлов в поле MEMO:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
'--------------------------------------------------------------------------
' Module    : modFilesInDB
' Author    : es
' Date      : 01.02.2011 -23.05.2016
' Purpose   : Хранение файлов в поле MEMO таблицы БД
'             Загрузка - Выгрузка
'--------------------------------------------------------------------------
Public Function esOutPutOneFileFromTable(strFilePath As String, _
                              strTableName As String, _
                              strFieldForFileName As String, _
                              strFieldForFileBody As String, _
                              strFileName As String)
'Копируем ОДИН (указанный) файл из таблицы - в указанную папку
'Аргументы:
' 1. strFilePath          = Полный путь к конечному файлу в виде: "C:\Temp\myfile.txt"
' 2. strTableName         = Название таблицы откуда
' 3. strFieldForFileName  = Название поля откуда брать названия файлов
' 4. strFieldForFileBody  = Название поля откуда брать тело файлов
' 5. strFileName          = Название файла
'--------------------------------------------------------------------------
 
Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim str As String
Dim v As Variant
Dim i As Long                 'Счетчик файлов
Dim x As Long                 'к-во записей в таблице
On Error GoTo esOutPutOneFileFromTableERR
    
    If Dir(strFilePath) <> "" Then Kill strFilePath 'Удаление файла
    DoEvents
 
'Определяем набор записей для работы
 
    
    str = "SELECT * FROM " & strTableName & " WHERE " & strFieldForFileName & " = '" & strFileName & "'"
    Set daoRst = CurrentDb.OpenRecordset(str, dbOpenSnapshot)
    If daoRst.EOF = True Then GoTo esOutPutOneFileFromTableExit
    v = daoRst.Fields(strFieldForFileBody)
    
'Запись файла
    Reset
    Open strFilePath For Output As #1
    Print #1, v;
    Close #1    ' Закрывает файл.
    
'Концовка
esOutPutOneFileFromTableExit:
    On Error Resume Next
    daoRst.Close
    Set daoRst = Nothing
    Close #1
    DoEvents
    Exit Function
 
esOutPutOneFileFromTableERR: 'Метка обработчика ошибок
    esOutPutOneFileFromTable = Err.Number
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure esOutPutOneFileFromTable of Module modData", vbCritical, "Error!"
 
    Err.Clear
    Resume esOutPutOneFileFromTableExit
End Function
 
Private Sub esPutFilesToTable(strStoragePath As String, _
                              strTableName As String, _
                              strFieldForFileName As String, _
                              strFieldForFileBody As String, _
                              Optional strExt As String = "*.*")
 
'Процедура копирования всех файлов указанной в аргументе
'strStoragePath папки - в таблицу у которой одно поле
'содержит имена исходных файлов, а другое их "тело" (MEMO)
'Аргументы:
' 1. strStoragePath       = путь к файлам в виде: "C:\Temp"
' 2. strTableName         = Название таблицы куда
' 3. strFieldForFileName  = Название поля куда сохранять названия файлов
' 4. strFieldForFileBody  = Название поля куда сохранять тело файлов MEMO!!!
'--------------------------------------------------------------------------
 
Dim Msg As String, Style As Integer  'Для вывода сообщения - предупреждения
Dim strFileName As String     'Название обрабатываемого в т.в. файла
Dim strFilePath As String     'Полный путь к обрабатываему в т.в. файлу
Dim varVal As Variant         'Для врем. хранения тела файла
Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim i As Long                 'Счетчик файлов
Dim lngFileLen As Long        'Размер файла
 
On Error GoTo esPutFilesToTableERR
 
'проверка на наличие левого слеша в аргументе пути (Не должно быть)
    If Mid(strStoragePath, Len(strStoragePath), 1) = "" Then
        strStoragePath = Mid(strStoragePath, 1, Len(strStoragePath) - 1)
    End If
'проверка на наличие пути
    If Dir(strStoragePath, vbDirectory) = "" Then
        MsgBox "Указанный путь к файлам " & vbCrLf & _
        strStoragePath & vbCrLf & _
        "не существует!!!", vbCritical
        Exit Sub
    End If
    
'Предупреждение об удалении старых данных
    Msg = "Имеющиеся данные из таблицы  =" & strTableName & "=  будут удалены..." & vbCrLf & _
    "Вы уверены ???"
    Style = vbYesNo + vbExclamation + vbDefaultButton1
    If MsgBox(Msg, Style, "Предупреждение") = vbNo Then Exit Sub
   
'Удаляем все старое из таблицы
        DoCmd.SetWarnings False
        CurrentDb.Execute "DELETE * FROM " & strTableName
 
'Определяем набор записей для заполнения
    Set daoRst = CurrentDb.OpenRecordset(strTableName, dbOpenDynaset)
 
'Начинаем перебор файлов в папке (не взирая на личности - все...)
    strFileName = Dir(strStoragePath & "\*.*")
        With daoRst
            'цикл по всем файлам в папке
            Do While strFileName <> ""   ' Начинает цикл.
                strFilePath = strStoragePath & "" & strFileName '=Полный путь
                lngFileLen = FileLen(strFilePath)
                Reset 'Если есть открытые - закрываем на усякий случай
                'Открываем файл на чтение
                Open strFilePath For Binary Access Read Lock Read As #1
                varVal = Input(lngFileLen, #1)   ' Читает тело файла.
                Close #1    ' Закрывает файл.
                
                'Собственно добавление в таблицу "выжатых" их файла байтов
                    .AddNew
                        .Fields(strFieldForFileName) = strFileName
                        .Fields(strFieldForFileBody) = varVal
                    .Update
                strFileName = Dir    ' Возвращает следующий элемент.
                varVal = Null
                i = i + 1
            Loop
        End With
    
'Концовка
    daoRst.Close
    Set daoRst = Nothing
    MsgBox "В таблицу принято - " & i & " файлов"
    Exit Sub
 
esPutFilesToTableERR: 'Метка обработчика ошибок
    MsgBox "Произошла ошибка №" & Err.Number & vbCrLf & Err.Description
    Err.Clear
End Sub
 
 
Public Function esOutPutFilesFromTable(strStoragePath As String, _
                              strTableName As String, _
                              strFieldForFileName As String, _
                              strFieldForFileBody As String) As Long
'Процедура обратная предидущей т.е. из таблицы копируем файлы в указанную папку
'Аргументы:
' 1. strStoragePath       = путь к файлам в виде: "C:\Temp"
' 2. strTableName         = Название таблицы откуда
' 3. strFieldForFileName  = Название поля откуда брать названия файлов
' 4. strFieldForFileBody  = Название поля откуда брать тело файлов
'--------------------------------------------------------------------------
Dim strFileName As String     'Название обрабатываемого файла
Dim strFilePath As String     'Полный путь к обрабатываему в т.в. файлу
Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim i As Long                 'Счетчик файлов
Dim x As Long                 'к-во записей в таблице
On Error GoTo esOutPutFilesFromTableERR
 
'проверка на наличие левого слеша в аргументе пути (Не должно быть)
    If Mid(strStoragePath, Len(strStoragePath), 1) = "" Then
        strStoragePath = Mid(strStoragePath, 1, Len(strStoragePath) - 1)
    End If
 
'Проверка на наличие пути
    If Dir(strStoragePath, vbDirectory) = "" Then
        MsgBox "Указанный путь к файлам " & vbCrLf & _
        strStoragePath & vbCrLf & _
        "не существует!!!", vbCritical
        Exit Function
    End If
 
    
    
'Определяем набор записей для работы
    Set daoRst = CurrentDb.OpenRecordset(strTableName, dbOpenSnapshot)
    If daoRst.EOF = True Then GoTo esOutPutFilesFromTableExit
    With daoRst
        .MoveLast
        .MoveFirst
        x = .RecordCount
            'Начинаем перебор записей и вывод файлов
            For i = 1 To x
                strFileName = .Fields(strFieldForFileName)
                
                'Получаем Полный путь к файлу
                    strFilePath = strStoragePath & "" & strFileName
                'Запись файла
                    Reset
                    Open strFilePath For Output As #1
                    Print #1, .Fields(strFieldForFileBody);
                    Close #1    ' Закрывает файл.
                If i < x Then .MoveNext
            Next i
    End With
    
'Концовка
esOutPutFilesFromTableExit:
    On Error Resume Next
    daoRst.Close
    Set daoRst = Nothing
    MsgBox "Из таблицы скопировано - " & x & " файлов"
    
    Exit Function
 
esOutPutFilesFromTableERR: 'Метка обработчика ошибок
    esOutPutFilesFromTable = Err.Number
    MsgBox "Произошла ошибка №" & Err.Number & vbCrLf & Err.Description
    Err.Clear
End Function

mobile · 08.12.2016, 02:02

Попробуйте такую процедуру в предположении, что все файлы в одной папке. И вставьте правильные имена полей, таблиц

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub addAttach(pathAttach)
'pathAttach - путь к документу. Например "c:\temp\фото"
  dim rst As dao.recordset2, rstA As dao.recordset2, db As dao.database
  set db = currentdb
  set rst = db.openrecordset("select * from Таблица")
  do until rst.eof
    rst.edit
    set rstA = rst.fields("ПолеВложения").value
    rstA.addnew
    rstA.fields("FileData").LoadFromFile pathAttach & "\" & id & ".png"
    rstA.update
    rst.update
    rst.movenext
  Loop
end sub

Написано без проверки, возможны ошибки.

Добавлено через 39 секунд
Ой, опоздал

@Spec_0994 · 08.12.2016, 02:27 **[ТС]**

Вот фото

Ребята написал вот такую проуедуру для заливки фото только ничего не работает.Что делаю не так?

Комментарий модератора

обычно выкладывают код, а не рисунок

@Eugene-LS · 08.12.2016, 04:09

Сообщение от Spec_0994

Что делаю не так?

Да пока все не так вы делаете.
Даже и не знаю ...
данный Код привязан к конкретным объектам БД (Таблицам и их Полям), а они у вас существуют?

@Spec_0994 · 08.12.2016, 04:16 **[ТС]**

Если можно опишите по подробнее как все это сделать? И на что эту процедуру к кнопке в форме прикреплять?

Добавлено через 2 минуты
Да существуют таблица FOTO в ней поля ID текстовое и поле foto вложение

@Eugene-LS · 08.12.2016, 08:52

Сообщение от Spec_0994

Да существуют таблица FOTO в ней поля ID текстовое и поле foto вложение

Ну как то так:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Public Function addAttach(pathAttach$, Optional fmask$ = "*.jpg") As Integer
' Вкладывает  (аттачит) файлы в таблицу "FOTO" и возвращает кол-во принятых файлов
' Аргументы:
'   pathAttach - путь к документу. Например "c:\temp\фото"
'   fmask      - маска файлов
'--------------------------------------------------------------------------
' Внимание!
'   Тип поля : "foto" = Attachment (Вложение)
'--------------------------------------------------------------------------
' "Литература":
'   [url]https://msdn.microsoft.com/en-us/library/office/ff197396.aspx[/url]
'   [url]https://msdn.microsoft.com/en-us/library/bb257442(v=office.12).aspx[/url]
'--------------------------------------------------------------------------
 
Dim rst As DAO.Recordset2, rstA As DAO.Recordset2
Dim path_und_mask$, s$, sf$
 
On Error GoTo addAttach_Err
' Проверочка:
    pathAttach = Trim(pathAttach)
    If Right(pathAttach, 1) <> "" Then pathAttach = pathAttach & "" ' Ну понятно ...
    
    
    Set rst = CurrentDb.OpenRecordset("select * from FOTO")
    path_und_mask = pathAttach & fmask  'путь к файлам с маской
 
'Перебор файлов в папке:
    s = Dir(path_und_mask, vbNormal)
    Do While s <> ""
        sf = pathAttach & s 'полный путь к текущему файлу
        'Debug.Print sf
        
        With rst
            .AddNew
            !ID = s ' Имя файла
 
            Set rstA = rst.Fields("foto").Value
                rstA.AddNew
                'Аттачим файлик в поле: "foto"
                rstA.Fields("FileData").LoadFromFile sf ' вкладываем Файл ...
                rstA.Update
                addAttach = addAttach + 1 'учёт ! :)
            .Update
        End With
        
        
        'следующий файл
        s = Dir
    Loop
 
addAttach_Bye:
    On Error Resume Next
    Set rstA = Nothing
    rstA.Close
    Set rst = Nothing
    rst.Close
    Exit Function
 
addAttach_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & "в процедуре: addAttach", vbCritical, "Error in module modTest00"
    Resume addAttach_Bye
 
End Function

Работает! - см пример (MSA 2007 и выше)
Спасибо mobile - навёл на идею.

@Spec_0994 · 10.12.2016, 08:44 **[ТС]**

Ребята, огромное спасибо за помощь!! Все работает! Особенно благодарю Eugene-LS очень помог.Спасибо.

Новые блоги и статьи Все статьи Все блоги /
Отчёт о затраченных материалах за определенный период с макетом печатной формы Maks 21.04.2026 Отчёт из решения ниже размещён в конфигурации КА2. Задача: разработка отчёта по затраченным материалам за определённый период, с возможностью вывода печатной формы отчёта с шапкой и подвалом. В. . .	Отчёт о спецтехнике находящейся в ремонте Maks 20.04.2026 Отчёт из решения ниже размещен в конфигурации КА2. Задача: отобразить спецтехнику, которая на данный момент находится в ремонте. Есть нетиповой документ "Заявка на ремонт спецтехники" который. . .	Памятка для бота и "визитка" для читателей "Semantic Universe Layer (Слой семантической вселенной)" Hrethgir 19.04.2026 Сгенерировано для краткого описания по случаю сборки и компиляции скелета серверного приложения. И пусть после этого скажут, что статьи сгенерированные AI - туфта и не интересно. И это не реклама -. . .	Запрет удаления строк ТЧ документа при определённом условии Maks 19.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "Аккумуляторы", разработанного в конфигурации КА2. У данного документа есть ТЧ, в которой в зависимости от прав доступа. . .
Модель заражения группы наркоманов alhaos 17.04.2026 Условия задачи сформулированы тут Суть: - Группа наркоманов из 10 человек. - Только один инфицирован ВИЧ. - Колются одной иглой. - Колются раз в день. - Колются последовательно через. . .	Мысли в слух. Про "навсегда". kumehtar 16.04.2026 Подумалось тут, что наверное очень глупо использовать во всяких своих установках понятие "навсегда". Это очень сильное понятие, и я только начинаю понимать край его смысла, не смотря на то что давно. . .	My Business CRM MaGz GoLd 16.04.2026 Всем привет, недавно возникла потребность создать CRM, для личных нужд. Собственно программа предоставляет из себя базу данных клиентов, в которой можно фиксировать звонки, стадии сделки, а также. . .	Знаешь почему 90% людей редко бывают счастливыми? kumehtar 14.04.2026 Потому что они ждут. Ждут выходных, ждут отпуска, ждут удачного момента. . . а удачный момент так и не приходит.

@Spec_0994 0 / 0 / 0 Регистрация: 01.11.2016 Сообщений: 62

	Автрматическая загрузка фото в таблицы с полем вложение 08.12.2016, 01:17. Показов 2472. Ответов 8 Метки нет (Все метки) Всем Привет.Нужна помощь.Есть огромное количество фотографий порядка 20 тысяч, их нужно загрузить в базу. Они ужаты максимально и в полном обьеме составляют не больше 150мб. Есть поле ln где написан каждый id и есть в папке фотографии которые подписаны как id.png. На фото видно фотки и видно поля в таблицы, они совпадают. Подскажите как их можно все загрузить в нужные строки в вложение в таблице? 0

@Spec_0994 0 / 0 / 0 Регистрация: 01.11.2016 Сообщений: 62
	08.12.2016, 04:16 [ТС]
	Если можно опишите по подробнее как все это сделать? И на что эту процедуру к кнопке в форме прикреплять? Добавлено через 2 минуты Да существуют таблица FOTO в ней поля ID текстовое и поле foto вложение 0

@Spec_0994 0 / 0 / 0 Регистрация: 01.11.2016 Сообщений: 62
	10.12.2016, 08:44 [ТС]
	Ребята, огромное спасибо за помощь!! Все работает! Особенно благодарю Eugene-LS очень помог.Спасибо. 0

Автрматическая загрузка фото в таблицы с полем вложение

Решение