Witam,

Chciałbym pobrać zdjęcia przechowywane w bazie jako warości bitowe i zapisać je do pliku Excela.

Pośrednio chciałem to zrobić w ten sposób:

1. najpierw z bazy generuję raport z nazwami plików - raport exportuję do Excela
2. wyciągam zdjęcia z bazy i zapisuję je do swojego katalogu
3. W Excelu odpalam makro, które zaczyta mi pliki do arkusza

W zasadzie takie coś już udało mi się zrobić i byłoby wszystko dobrze gdyby nie to, że po odpaleniu makra zdjęcia w rzeczywistości nie są importowane do Excela lecz tylko tworzone są w na arkuszu obiekty typu Picture, które zawierają adresację do zdjęć we wskazanym katalogu.
Jeżeli usunę katalog to pozostają w Excelu niewypełnione obiekty.

Export raportu i Export plików pomijam, natomiast niżej przedstawiam makro, które zaciąga zdjęcia ze wskazanego katalogu do wskazanej kolumny.
Makro pobiera po kolei:
- ścieżkę do katalogu w którym są wcześniej wyexportowane zdjęcia
- ilość wierszy z nazwami plików
- kolumnę w której są nazwy plików
- kolumnę do której będą wpisywane pobrane zdjęcia

[SQL] pobierz, plaintext 
Sub test()
Application.ScreenUpdating = False
Dim i AS Integer, p AS Picture, r AS Range, c AS Range, ii AS Integer, DirFile AS String, pPath AS String
 
Dim rowsQty AS Integer, fileNamesCol AS String, imageDestCol AS String, pathToFiles AS String
 
pathToFiles = InputBox("Podaj ścieżkę do plików", "Ścieżka")
rowsQty = InputBox("Podaj ilość wierszy z danymi", "Ilość wierszy")
fileNamesCol = InputBox("Podaj nazwę kolumny z nazwami zdjęć", "Kolumna z nazwami")
imageDestCol = InputBox("Podaj nazwę kolumny gdzie będą zapisywane zdjęcia", "Kolumna docelowa")
 
fileNamesCol = fileNamesCol + "1:" + fileNamesCol + CStr(rowsQty)
pathToFiles = pathToFiles + "\"
 
ii = 0
Set r = ActiveSheet.Range(fileNamesCol)
ActiveSheet.DrawingObjects.Delete
For Each c In r
ii = ii + 1
If c <> "" Then
 
DirFile = c.Value
DirFile = pathToFiles + DirFile
 
With ActiveSheet
 
Set p = .Pictures.Insert(DirFile)
.DrawingObjects(p.Name).Left = .Columns(imageDestCol).Left
.DrawingObjects(p.Name).Top = .Rows(ii).Top
.Rows(ii).RowHeight = p.Height
.DrawingObjects(p.Name).Placement = xlMoveAndSize
.DrawingObjects(p.Name).PrintObject = True
 
End With
 
End If
 
Next c
Application.ScreenUpdating = True
End Sub
[SQL] pobierz, plaintext