Excel den word' e resim ve metin aktarma...

[pNouma]

Merhaba,
Excel sayfasının A sütununda resimler, "B:F" sütun aralığında bu resime ait bilgiler bulunmakta;

Ekli 1.. nolu görselde "A" sütunda bulunan görseli; önce word dosyasına aktarmak istiyorum,

Resim word dosyasına aktarıldıktan sonra, resmin altına "B:F" sütun aralığında bulunan verileri, 2 nolu görselde olduğu gibi alt-alta yazdırması için nasıl bir kod yazılabilir,

https://dosya.co/gulmcip9cwai/123.jpg.html
https://dosya.co/ig0agv846xai/1234.jpg.html

https://dosya.co/d36vwh9yh8ad/Kitap1.xlsx.html
https://dosya.co/2oruyels7l9x/00472254.docx.html

Aşağıdaki kod ile resimi kopyalayabiliyorum, yalnız altına yazıları nasıl yazdırabiliriz?

Sub ExportToWord_Example2()
Dim WS As Worksheet
Dim WordApp As Object
Dim doc As Object
Dim rng As Range


Set WS = Worksheets("Sheet1")

Set WordApp = CreateObject("Word.Application")
With WordApp
.Visible = True
Set doc = .Documents.Add
End With

With WordApp
    WS.Shapes("Picture 1").Copy
    .Selection.Paste
 
End With

   doc.Paragraphs(doc.Paragraphs.Count).Range.InsertParagraphAfter
   
For i = 2 To 6
WS.Cells(2, i).Copy
        doc.Paragraphs(doc.Paragraphs.Count).Range.Paste
        Application.CutCopyMode = False
 ''
Next i

End Sub

yardımlarınız için şimdiden teşekkür ederim.
iyi Çalışmalar.

 

[halit3]

kod

'referanslarda bu olmalı
'microsoft word xx.0 object library

Sub resimkayıtet()

Kaynak = ThisWorkbook.Path

sat = 1
sut = 1
say2 = 1
say = 0
say3 = 1
sayi = 2


Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True
With wrdDoc
.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 15 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 15 'üst
.BottomMargin = 10 '20 ' alt

.Orientation = wdOrientPortrait
yükseylik = 176

End With
End With


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then

say = say + 1

If say Mod sayi = 2 Then
sut = sut + 1
End If



If say = 2 Then
sut = sut + 1
say3 = say3 + 1
End If



If say = 1 Then
wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.Selection.Range, NumRows:=6, NumColumns:=sayi

With wrdApp.ActiveDocument.Tables(1)
If .Style <> "Tablo Kılavuzu" Then
'.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
End If

sat2 = Picture.BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paragraphs.WordWrap = True
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paste

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat, sut)
'.Range.Paragraphs.WordWrap = True
'.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = 230
.Range.InlineShapes(1).Width = 100
End With


wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 1, sut).Range = Cells(sat2, 2)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 2, sut).Range = Cells(sat2, 3)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 3, sut).Range = Cells(sat2, 4)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 4, sut).Range = Cells(sat2, 5)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Range = Cells(sat2, 6)

If sut = sayi Then
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Select
wrdApp.Selection.MoveDown Unit:=wdLine, Count:=1
'wrdApp.Selection.TypeParagraph
End If

If sut = 2 Then
sut = 1
say = 0
sat = sat + 6
End If


End If

Next Picture
son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi

End With


wrdDoc.Close
wrdApp.Quit

MsgBox "işlem tamam"

End Sub

 

[pNouma]

kod

'referanslarda bu olmalı
'microsoft word xx.0 object library

Sub resimkayıtet()

Kaynak = ThisWorkbook.Path

sat = 1
sut = 1
say2 = 1
say = 0
say3 = 1
sayi = 2


Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True
With wrdDoc
.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 15 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 15 'üst
.BottomMargin = 10 '20 ' alt

.Orientation = wdOrientPortrait
yükseylik = 176

End With
End With


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then

say = say + 1

If say Mod sayi = 2 Then
sut = sut + 1
End If



If say = 2 Then
sut = sut + 1
say3 = say3 + 1
End If



If say = 1 Then
wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.Selection.Range, NumRows:=6, NumColumns:=sayi

With wrdApp.ActiveDocument.Tables(1)
If .Style <> "Tablo Kılavuzu" Then
'.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
End If

sat2 = Picture.BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paragraphs.WordWrap = True
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paste

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat, sut)
'.Range.Paragraphs.WordWrap = True
'.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = 230
.Range.InlineShapes(1).Width = 100
End With


wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 1, sut).Range = Cells(sat2, 2)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 2, sut).Range = Cells(sat2, 3)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 3, sut).Range = Cells(sat2, 4)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 4, sut).Range = Cells(sat2, 5)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Range = Cells(sat2, 6)

If sut = sayi Then
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Select
wrdApp.Selection.MoveDown Unit:=wdLine, Count:=1
'wrdApp.Selection.TypeParagraph
End If

If sut = 2 Then
sut = 1
say = 0
sat = sat + 6
End If


End If

Next Picture
son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi

End With


wrdDoc.Close
wrdApp.Quit

MsgBox "işlem tamam"

End Sub

çok Teşekkür ederim Hailt Hocam,
iyiki varsınız !
bir şey daha istesem çok olur mu acaba?
Burada Word Dosyası yerine Power point ' e veri göndermek istesek bu yapılabilir mi acaba?
Aynı şekilde word sayfaları yerine power point sunularına atmak

tekrar teşekkürler,
iyi çalışmalar.

 

[halit3]

kod:

'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
say = 0

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
say = say + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)

pptSlide.Shapes.PasteSpecial
pptSlide.Select

With pptSlide.Shapes(1)
If .Type = msoPicture Then
.Top = 87
.Left = 33
.Height = 222
.Width = 290
End If

bas = 90
For k = 1 To 5

pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 340, bas, 340, 22).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With pptApp.ActiveWindow.Selection.TextRange
.Text = Cells(1, k + 1) & " = " & Cells(sat2, k + 1)
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
pptApp.ActiveWindow.Selection.ShapeRange.Fill.Visible = msoFalse
pptApp.ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = ppAlignLeft

End With
End With

pptApp.ActiveWindow.Selection.Unselect
bas = bas + 40
Next k
End With

End If

Next Picture

pptApp.Visible = True
son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"


pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

MsgBox "işlem tamam"

End Sub

 

[halit3]

bu kod da metin nesnesiyle yapılmıştır çerçeve yok

'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
say = 0

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
say = say + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)

pptSlide.Shapes.PasteSpecial
pptSlide.Select

With pptSlide.Shapes(1)
If .Type = msoPicture Then
.Top = 87
.Left = 33
.Height = 222
.Width = 290
End If

bas = 90
For k = 1 To 5

pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 340, bas, 340, 22).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue

Set sayf = Workbooks(dosya_adı).Sheets(Sayfa_Adı) '.Cells(sat2, 2).Value

With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(1, k + 1) & " = " & sayf.Cells(sat2, k + 1)
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With

pptApp.ActiveWindow.Selection.Unselect
bas = bas + 40
Next k
End With

End If

Next Picture

son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"

pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

Windows(dosya_adı).Activate
MsgBox "işlem tamam"

End Sub

 

[pNouma]

Halit Hocam çok teşekkürler,
Burada power point dosyasında her bir sayfaya tek bir görsel geliyor,
word dosyasında olduğu gibi 1 sayfada yana 5 görsel getirilmesi sağlanamaz mı?

yeniden rahatsız ettiğim için lütfen kusura bakmayın.
iyi akşamlar.

 

[halit3]

Tamamdır bundan sonra değişiklik yok

'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint2()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
say = 0

ReDim ara1(50000): ReDim ara2(50000)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
say = say + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row

ara1(say) = Picture.Name
ara2(say) = sat2

End If
Next Picture

ekle = 0
j = 0
m = 0
top1 = 20

For i = 1 To say
j = j + 1
ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

If j = 1 Then

pptApp.ActiveWindow.View.GotoSlide Index:=pptApp.ActivePresentation.Slides.Add(Index:=1, Layout:=ppLayoutTitle).SlideIndex
pptApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Cut
pptApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Cut

End If

ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
pptApp.ActiveWindow.View.Paste
ad = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad).Select

With pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad)
If .Type = msoPicture Then
.Top = 30 + ekle
.Left = 33
.Height = 90
.Width = 90
End If
End With

pptApp.ActiveWindow.Selection.Unselect

For k = 1 To 1
pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 140, top1, 440, 100).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue

Set sayf = Workbooks(dosya_adı).Sheets(Sayfa_Adı)

With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(1, 2) & " = " & sayf.Cells(ara2(i), 2) & Chr(11) & sayf.Cells(1, 3) & " = " & sayf.Cells(ara2(i), 3) & Chr(11) & sayf.Cells(1, 4) & " = " & sayf.Cells(ara2(i), 4) & Chr(11) & sayf.Cells(1, 5) & " = " & sayf.Cells(ara2(i), 5) & Chr(11) & sayf.Cells(1, 6) & " = " & sayf.Cells(ara2(i), 6)

With .Font
.Name = "Arial"
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
'.Color.SchemeColor = ppForeground
End With
End With

pptApp.ActiveWindow.Selection.Unselect
top1 = top1 + 100
Next k

ekle = ekle + 100
m = m + 5
If j = 5 Then j = 0: ekle = 0: top1 = 20

Next i

son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"

pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

Windows(dosya_adı).Activate
MsgBox "işlem tamam"

End Sub

 

[halit3]

farklı kod

'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint2()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

ReDim ara1(50000): ReDim ara2(50000)

son = 0
ekle1 = 0
ekle2 = 1
j = 0

top1 = 20


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
son = son + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row
ara1(son) = Picture.Name
ara2(son) = sat2
End If
Next Picture



For i = 1 To son
j = j + 1
ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

If j = 1 Then
pptApp.ActiveWindow.View.GotoSlide Index:=pptApp.ActivePresentation.Slides.Add(Index:=ekle2, Layout:=ppLayoutBlank).SlideIndex
End If


ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
pptApp.ActiveWindow.View.Paste
ad = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad).Select

With pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad)
pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse

If .Type = msoPicture Then
.Top = 26 + ekle1
.Left = 33
.Width = 100
.Height = 90

End If
End With

pptApp.ActiveWindow.Selection.Unselect

Set sayf = Workbooks(dosya_adı).Sheets(Sayfa_Adı)

For k = 1 To 1
pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 140, top1, 160, 100).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue
With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(1, 2) & Chr(11) & sayf.Cells(1, 3) & Chr(11) & sayf.Cells(1, 4) & Chr(11) & sayf.Cells(1, 5) & Chr(11) & sayf.Cells(1, 6)
With .Font
.Name = "Arial"
.Size = 16
.Color.RGB = RGB(255, 0, 0)
End With
End With
pptApp.ActiveWindow.Selection.Unselect
Next k

For k = 1 To 1
pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 300, top1, 200, 100).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue
With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(ara2(i), 2) & Chr(11) & sayf.Cells(ara2(i), 3) & Chr(11) & sayf.Cells(ara2(i), 4) & Chr(11) & sayf.Cells(ara2(i), 5) & Chr(11) & sayf.Cells(ara2(i), 6)
With .Font
.Name = "Arial"
.Size = 16
End With
End With
pptApp.ActiveWindow.Selection.Unselect
top1 = top1 + 100
Next k


ekle1 = ekle1 + 100

If j = 5 Then j = 0: ekle1 = 0: top1 = 20: ekle2 = ekle2 + 1

Next i

son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"

pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

Windows(dosya_adı).Activate
MsgBox "işlem tamam"

End Sub

 

[pNouma]

Çok teşekkür ederim Halit Hocam