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