AccessTr.neT

Tam Versiyon: Access'ten Excel'e Gömülü Fotoğraf Aktarma
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Sayfalar: 1 2
(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 Img-grin 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 Img-grin
Merhaba, eklediğiniz örnek uygulama Accessden Excele Resim Aktarma bağlantısına yeni konu olarak eklenmiştir.
Bana bunun tersi lazım ama Img-grin
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.
Sayfalar: 1 2