(24/12/2017, 22:52)direnist yazdı: [ -> ]Merhaba sn. donapezil;
Öncelikle rica ederim. Bu hali ile bile işinize yarıyor olmasına ayrıca çok sevindim.
Açıkçası konunuzu ilk okuduğumda bende yapılamaz diye düşündüm. Çünkü, Excel kitabı içinde hücrenin içine fotoğrafı gömülü şekilde ekleyebilmenin bayağı bir kod yazımı yada uzun bir algoritma gerektireceğini düşündüm.
Ancak sizin araştırmalarınız sonucunda ulaştığınız sayenizde benim de öğrendiğim (bunun için bende size teşekkür ederim) "xlSheet.Shapes.AddPicture PicLocation, False, True, 125, y, 100, 100" kodunu görünce bunun üzerinden ilerleyerek acemice bişeyler yaptım. Aslında kod tarafı daha dinamik olabilir.
Ve şu hatayı da düzeltebilseydim daha güzel olurdu.
Belirttiğiniz gibi hocalarımız müsait olduğunda bakabilirler ise ki eminim başka bir profesyonel bir yolu da vardır.
Bende çok merak ediyorum bu konuyu.
İyi çalışmalar.
Saygılar.
Sn direnist;
Yıllardır burada konu açarken, hep altından kalkamayacağım konularla ilgili konu açtım, diğer taraftan da araştırmaya hep devam ettim. Ödev yaptırmak isteyen öğrenciler gibi konuyu ortaya atıp çekilmemişimdir
Bu kodu bulmam da bunun sonucu oldu. Başta Ozan hocam olmak üzere, pekçok kişinin emeği vardır öğrendiklerimde. Artık sizin de oldu. Eminim ki üstadlar, konuyu inceleyip, herkesin işine yarayacak hale getirecekledir.
Tekrar çok teşekkür ediyorum.
Saygılar, iyi çalışmalar.
Merhaba,
Butonun tıklandığında olayındaki kodu aşağıdaki ile değiştirerek deneyiniz.
Private Sub Komut14_Click()
On Error GoTo hata
Dim xls As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim rng As Range
Dim PicLocation
Dim i, k, satir, sutun, x, y, alan_adedi As Integer
Dim rs As Object
Set rs = New ADODB.Recordset
rs.Open "select * from sorgu1", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
alan_adedi = rs.Fields.Count
sutun = DCount("*", "sorgu1") + 1
Set xls = New Excel.Application
xls.Visible = True
Set wb = xls.Workbooks.Add
Set ws = wb.Sheets(1)
Set rng = ws.Range("A1")
ws.Name = "Ürün Bilgileri"
With rng
satir = 2
.Range("A1:E" & sutun).EntireColumn.ColumnWidth = 22
.Rows(CStr(satir) & ":" & CStr(sutun)).RowHeight = 120
.Range("A1:E" & sutun).HorizontalAlignment = xlCenter
.Range("A1:E" & sutun).VerticalAlignment = xlCenter
.Range("A1:E" & sutun).WrapText = False
.Range("A1:E" & sutun).Orientation = 0
.Range("A1:E" & sutun).AddIndent = False
.Range("A1:E" & sutun).IndentLevel = 0
.Range("A1:E" & sutun).ShrinkToFit = False
.Range("A1:E" & sutun).ReadingOrder = xlContext
.Range("A1:E" & sutun).MergeCells = False
y = 20
rs.MoveFirst
For i = 1 To alan_adedi
.Cells(1, i).Value = rs.Fields(i - 1).Name
Next i
Do While Not rs.EOF
For k = 1 To alan_adedi
PicLocation = rs.Fields("ÜRÜN FOTO")
k = 1
.Cells(satir, k) = rs.Fields("SIRA NO")
k = k + 1
ws.Shapes.AddPicture PicLocation, False, True, 125, y, 100, 100
k = k + 1
.Cells(satir, k) = rs.Fields("ÜRÜN ADI")
k = k + 1
.Cells(satir, k) = rs.Fields("ÜRÜN KODU")
k = k + 1
.Cells(satir, k) = rs.Fields("ÜRÜN AÇIKLAMA")
satir = satir + 1
y = y + 120
Next k
rs.MoveNext
Loop
End With
rs.Close
Set rs = Nothing
wb.SaveAs CurrentProject.Path & "\Urun_Agaci" & Date & ".xlsx"
wb.Close False
Set wb = Nothing
xls.Quit
Set xls = Nothing
Set xls = Nothing
Set wb = Nothing
Set ws = Nothing
hata:
If Err.Number = "1004" Then
MsgBox ("Aktarım İptal Edildi")
wb.Close False
Set wb = Nothing
xls.Quit
Set xls = Nothing
Set wb = Nothing
Set ws = Nothing
Exit Sub
ElseIf Err.Number <> 0 Then
MsgBox (Err.Number & "" & Err.Description)
Resume Next
End If
End Sub
(26/12/2017, 12:29)ozanakkaya yazdı: [ -> ]Merhaba,
Butonun tıklandığında olayındaki kodu aşağıdaki ile değiştirerek deneyiniz.
Private Sub Komut14_Click()
On Error GoTo hata
Dim xls As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim rng As Range
Dim PicLocation
Dim i, k, satir, sutun, x, y, alan_adedi As Integer
Dim rs As Object
Set rs = New ADODB.Recordset
rs.Open "select * from sorgu1", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
alan_adedi = rs.Fields.Count
sutun = DCount("*", "sorgu1") + 1
Set xls = New Excel.Application
xls.Visible = True
Set wb = xls.Workbooks.Add
Set ws = wb.Sheets(1)
Set rng = ws.Range("A1")
ws.Name = "Ürün Bilgileri"
With rng
satir = 2
.Range("A1:E" & sutun).EntireColumn.ColumnWidth = 22
.Rows(CStr(satir) & ":" & CStr(sutun)).RowHeight = 120
.Range("A1:E" & sutun).HorizontalAlignment = xlCenter
.Range("A1:E" & sutun).VerticalAlignment = xlCenter
.Range("A1:E" & sutun).WrapText = False
.Range("A1:E" & sutun).Orientation = 0
.Range("A1:E" & sutun).AddIndent = False
.Range("A1:E" & sutun).IndentLevel = 0
.Range("A1:E" & sutun).ShrinkToFit = False
.Range("A1:E" & sutun).ReadingOrder = xlContext
.Range("A1:E" & sutun).MergeCells = False
y = 20
rs.MoveFirst
For i = 1 To alan_adedi
.Cells(1, i).Value = rs.Fields(i - 1).Name
Next i
Do While Not rs.EOF
For k = 1 To alan_adedi
PicLocation = rs.Fields("ÜRÜN FOTO")
k = 1
.Cells(satir, k) = rs.Fields("SIRA NO")
k = k + 1
ws.Shapes.AddPicture PicLocation, False, True, 125, y, 100, 100
k = k + 1
.Cells(satir, k) = rs.Fields("ÜRÜN ADI")
k = k + 1
.Cells(satir, k) = rs.Fields("ÜRÜN KODU")
k = k + 1
.Cells(satir, k) = rs.Fields("ÜRÜN AÇIKLAMA")
satir = satir + 1
y = y + 120
Next k
rs.MoveNext
Loop
End With
rs.Close
Set rs = Nothing
wb.SaveAs CurrentProject.Path & "\Urun_Agaci" & Date & ".xlsx"
wb.Close False
Set wb = Nothing
xls.Quit
Set xls = Nothing
Set xls = Nothing
Set wb = Nothing
Set ws = Nothing
hata:
If Err.Number = "1004" Then
MsgBox ("Aktarım İptal Edildi")
wb.Close False
Set wb = Nothing
xls.Quit
Set xls = Nothing
Set wb = Nothing
Set ws = Nothing
Exit Sub
ElseIf Err.Number <> 0 Then
MsgBox (Err.Number & "" & Err.Description)
Resume Next
End If
End Sub
Ozan hocam, herzamanki gibi hızırlığını gösterdin... Harika olmuş. Bu konuda sıkıntı çeken herkese mükemmel bir örnek oldu bu.
Önce sn direnist'in koduyla işimizi çözdük, şimdi de kusursuz çalışan kodla tüm çalışmalaraıma ve arşive ekliyorum.
Minnacık bir dokunuşta ben yaptım. Arka arkaya alınacak farklı raporlarda kayıt çakışması olmasın diye.
Kayıt yaptırma kodunu
Kod:
wb.SaveAs CurrentProject.Path & "\Urun_Agaci" & Format(Now, "dd-mm-yyyy h-mm-ss") & ".xlsx"
olarak güncelledim.
Güncel kodlu halini de ekliyorum. İsteyen doya doya kullansın. Artık
Excel içine gömülü fotoğraf aktarma sıkıntısı bitmiştir.
Emeği geçen sn. direnist'e ve Ozan hocama sonsuz saygılarımla...
Konu taşınabilir. Hatta
Access örneklerine taşınabilir
Bana bunun tersi lazım ama
Accessden Excele Resim Aktarma değil Excelden
Access e resim aktarma ?
öğrenci isimleri ve fotoğrafları olan listeyi E-okuldan .htm olarak kaydettim. Şimdi bu htm sayfalarından öğrenci resimlerini accessteki ogrenciler tablosuna aktarmak istiyorum.