Word Sabit Bir Tablo oluşturup, içerisine fotoğraf eklemek

[hadromer]

Merhaba,
Bir çalışmam için oldukça yüklü miktarda veri mevcut. Veriler fotoğraflardan oluşuyor. Ben bu fotoğrafların aynı bölgeye ait olanları sınıflandırmak istiyorum. Her bölgenin kendine ait farklı fotoğrafları var. Öneğin; Bir tablo oluşturup, A bölgesine ait 8 fotoğrafı bir tablo içerisine eklemek istiyorum. Her fotoğrafın altında fotoya ait iki cümle olacak. Sayfa yatay veya dikey olabilir sorun olmaz. Benim sormak istediğim şu ; Wordde bir şablon oluşturup fotoğrafları o şablon üzerinden ekleyebilir miyim ? yani bir tablo standardı oluşturmak istiyorum. Veri çok olduğu için sürekli sıfırdan tablo oluşturmak ve bir öncekiyle hizalamayla uğraşmak istemiyorum. Word'e alternatif başka bir program da olabilir. Yardımlarınızı bekliyorum. Teşekkür ederim. İlk foto da "+" işaretli yerlere fotoğraf, "-" işaretli yerlere de o fotoğrafa ait isim yazılacak. Tabloyu oluşturmakta sıkıntı yok fakat içerisine fotoğrafı ekleyince ikinci fotoğrafta ki gibi kaymalar oluyor. Tek tek bunları düzenlemek büyük zorluk olacak benim için.

 

[işsiz123]

Örnek dosya eklerseniz daha hızlı cevap alırsınız.

 

[hadromer]

şimdi ekledim örnek fotoğrafları. Dosyayı henüz oluşturmadığım için dosya şeklinde ekleyemedim

 

[halit3]

Alternatif olarak aşağıdaki linkleri irdeleyiniz.
https://www.excel.web.tr/threads/makro-ile-word-dosyasina-klasoerdeki-resimleri-eklemek.163908/
https://www.excel.web.tr/threads/word-birlestirmek.178201/#post-978162

 

[hadromer]

Alternatif olarak aşağıdaki linkleri irdeleyiniz.
https://www.excel.web.tr/threads/makro-ile-word-dosyasina-klasoerdeki-resimleri-eklemek.163908/
https://www.excel.web.tr/threads/word-birlestirmek.178201/#post-978162

hocam çok teşekkür ederim, aradığım böyle birşeydi. Lakin kodu nerede çalıştırmam gerektiği konusunda kısa bir yardımda daha bulunabilir misiniz ? zira altın üye olmadığım için dosyayı indiremedim.

 

[halit3]

https://www.excel.web.tr/threads/makro-ile-word-dosyasina-klasoerdeki-resimleri-eklemek.163908/
yukarıdaki linkde kodlar açık zaten kodları bir modüle yapıştıracaksınız kodu çalıştırmak içinde bir komut düğmesi ekliyecaksiniz.
Makro bilginiz varsa bu işlemleri kendiniz yapabilirsiniz

 

[hadromer]

https://www.excel.web.tr/threads/makro-ile-word-dosyasina-klasoerdeki-resimleri-eklemek.163908/
yukarıdaki linkde kodlar açık zaten kodları bir modüle yapıştıracaksınız kodu çalıştırmak içinde bir komut düğmesi ekliyecaksiniz.
Makro bilginiz varsa bu işlemleri kendiniz yapabilirsiniz

hocam çok teşekkür ederim. Peki şöyle bir şey yapabilir miyiz ? Sanki böyle bir yöntem varsa daha pratik olur gibi geldi bana. Aşağıda örnek bir dosya e ekledim. Word dosyalarım bu şekilde. Bir makro kodu ile word dosyasındaki fotoğrafları ve altındaki yazıyı seçip her sayfada 5-6 tane olacak şekilde sıralayabilir miyiz ?

İndirme Linki : https://www.dosyayukle.biz/8RX

 

[halit3]

örnek dosyayı kendiniz eklemişsiniz birde olması gereken dosyayı da ekleyin

 

[hadromer]

örnek dosyayı kendiniz eklemişsiniz birde olması gereken dosyayı da ekleyin

buyrun hocam. olmasını istedigim şekil bu. Örnek olması açısından 6 kareyi de aynı fotoğraftan seçtim, elbette gerçeğinde her biri farklı olacak. https://www.dosyayukle.biz/8S1

 

[halit3]

dosya inmiyor

 

[hadromer]

dosya inmiyor

hocam yeniden yükledim, buyrun ;
örnek dosya : https://s4.dosya.tc/server7/m5p7f6/ornek.docx.html
olmasını istedigim hali https://s4.dosya.tc/server7/7ts9zq/ornek_2.docx.html

 

[halit3]

Bu kodu bir modülün içine ekle ve tablo_word1 makrusunu çalıştır.

not 'referanslar
'Microsoft Word 12.0 Object Library

Dim son1 As Long

#If Win64 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function DestroyIcon& Lib "user32" (ByVal hIcon&)
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare Function DestroyIcon& Lib "user32" (ByVal hIcon&)
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If


Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
Dim bulunan2
Dim satdd


Sub ImageToMePicture()
Dim hCopy&: OpenClipboard 0&
' Bitmap = 2 / Metafile = 14
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim IPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
' Bitmap = 1 / Metafile = 4
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, IPic)
If Ret Then Exit Sub

Klasor = ThisWorkbook.Path & "\"
satdd = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

SavePicture IPic, Klasor & satdd & ".jpg" '".bmp"
Set IPic = Nothing
End Sub

Sub tablo_word1()

Dim objDialog, intResult
Set objDialog = CreateObject("MSComDlg.CommonDialog")
objDialog.Flags = 4
objDialog.Filter = "DosyalarExcel Files (.doc)|*.doc"
objDialog.FilterIndex = 1

objDialog.InitDir = ThisWorkbook.Path
objDialog.ShowOpen
intResul = objDialog.Filename
If Len(intResul) = 0 Then
Dim Msg
Msg = "Dosya seçmediniz."
MsgBox Msg, vbInformation + vbCritical
Set objDialog = Nothing
Else
yol = objDialog.Filename



Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

'Dosya = "deneme"
'Cells.ClearContents
'Cells(1, 15) = Dosya
'yol = ActiveWorkbook.Path & "\" & Dosya & ".doc"

Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
Application.WindowState = wdWindowStateMinimize

Dim son
sat = 1
say1 = 2

For Each ImgItem In docWord.InlineShapes
iCnt = iCnt + 1

If ImgItem.Type = wdInlineShapePicture Then
ImgItem.Select
objWord.Selection.CopyAsPicture
End If
Next

If objWord.ActiveDocument.Tables.Count > 0 Then
aranan = "Tür / Species"
satson = objWord.ActiveDocument.Tables(1).Rows.Count
sutson = objWord.ActiveDocument.Tables(1).Columns.Count

For r = 1 To objWord.ActiveDocument.Tables(1).Rows.Count
bulunan = objWord.ActiveDocument.Tables.Item(1).Cell(r, 1).Range.Text

k = InStr(1, bulunan, aranan)
If k > 0 Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(1).Cell(r, 2).Range.Text, "", "")
End If
Next r
End If

docWord.Close SaveChanges:=wdPromptToSaveChanges 'SaveChanges:=False

Call ImageToMePicture
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

objWord.Quit
Set docWord = Nothing

dosyaolustur

MsgBox "işlem tamam"
End If
Set objDialog = Nothing
End Sub


Sub dosyaolustur()

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

yol = ThisWorkbook.Path & "\"
sayi = 3
   
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True


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

'If msg1 = vbYes Then
'.Orientation = wdOrientPortrait
'yükseylik = 189
'Else
.Orientation = wdOrientLandscape
yükseylik = 230
'End If

End With

With wrdApp.ActiveDocument

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, 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 With

ekle1 = 0
sat = 0
Say = 0

Klasor = ThisWorkbook.Path & "\"

Dosya = Klasor & satdd & ".jpg"

For s = 1 To 6

Say = Say + 1
If Say Mod sayi = 1 Then
sut = 1
sat = sat + 1 + ekle1
ekle1 = 1
son = wrdApp.ActiveDocument.Tables(1).Rows.Count ' satır kontrol
If wrdApp.ActiveDocument.Tables.Count >= 1 Then
If Say > 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
End If
Else
sut = sut + 1
End If

wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range = bulunan2

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat, sut)
.Range.Paragraphs.WordWrap = True
.Range.InlineShapes.AddPicture Filename:=Dosya, LinkToFile:=False, SaveWithDocument:=True
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yükseylik
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

Next

son1 = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
'wrdApp.Documents(wrdDoc.Name).Activate

End Sub

 

[hadromer]

Halit3 hocam çok teşekkür ederim, elinize sağlık. Benim için uğraşıp yazmışsınız, minnettarım. Makro bilgim biraz zayıf olduğu için çalıştıramadım sanırım. içinde fotolar olan word dosyasını açıp alt+f11 tuşuna bastığımda çıkan pencereye kodu ekledim. Fotoğraftaki hata mesajını aldım. Sizi yoruyorum ama, nerede hata yaptığımı söyleyebilir misiniz ?

 

[halit3]

kodları excelin modül sayfasına kopyalıyacaksınız
excel açıkken alt+F11 tuşlarına birlikte bas sonra yukarıdaki menülerden ınser menüsünden modüle yi seç açılan modul penceresine yapıştır.

uyarı: küçücük bir makro bilginiz yoksa bu kodları çalıştıramazsınız.

 

[Haluk]

kodları excelin modül sayfasına kopyalıyacaksınız
excel açıkken alt+F11 tuşlarına birlikte bas sonra yukarıdaki menülerden ınser menüsünden modüle yi seç açılan modul penceresine yapıştır.

uyarı: küçücük bir makro bilginiz yoksa bu kodları çalıştıramazsınız.

Halit Bey;

@hadromer 'ın eklediği resme göre; sizin dediklerinizi yapmış ancak; sizin kullandığınız "CommonDialog" nesnesine ait DLL onun bilgisayarında olmadığı veya register edilmediği için 76.satırda hata oluşuyor.

Sizde VB6 yüklü olduğu için bu nesneyi kullanabiliyorsunuz ama, herkeste olmayabilir... Dosya açmak veya kullanıcıya dosya yolu göstermek için VBA'nin kendi metodlarını kullanmanız daha yararlı olur.

@hadromer ;

Kodları "Word" değil, "Excel" dosyasında kullanmanız gerekiyordu..... Halit Beyin 12 No'lu mesajının ekinde ilgili dosyalar zaten hazır olarak verilmiş.


.

 

[hadromer]

Halit Bey;

@hadromer 'ın eklediği resme göre; sizin dediklerinizi yapmış ancak; sizin kullandığınız "CommonDialog" nesnesine ait DLL onun bilgisayarında olmadığı veya register edilmediği için 76.satırda hata oluşuyor.

Sizde VB6 yüklü olduğu için bu nesneyi kullanabiliyorsunuz ama, herkeste olmayabilir... Dosya açmak veya kullanıcıya dosya yolu göstermek için VBA'nin kendi metodlarını kullanmanız daha yararlı olur.

.

Halit Bey;

@hadromer 'ın eklediği resme göre; sizin dediklerinizi yapmış ancak; sizin kullandığınız "CommonDialog" nesnesine ait DLL onun bilgisayarında olmadığı veya register edilmediği için 76.satırda hata oluşuyor.

Sizde VB6 yüklü olduğu için bu nesneyi kullanabiliyorsunuz ama, herkeste olmayabilir... Dosya açmak veya kullanıcıya dosya yolu göstermek için VBA'nin kendi metodlarını kullanmanız daha yararlı olur.

.

@Haluk Abi vallaha teşekkür ediyorum, Halit Bey'in dediklerini excel de de yaptım, lakin bu seferde compile error user defined type not defined hatası verdi. ve en baştaki Sub tablo_word1() sarı işaretli olarak kalıyor. yine çalıştıramadım kodu. Utandığımdan Halit Bey'e yeniden sormaya da çekinmiştim

 

[halit3]

Bu kodu bir dene dosya açma penceresi geliyormu ona göre kodu revize edeceğim.

Sub ShowFileDialog2()
Dim fd As FileDialog
Dim selectedPaths() As String
Dim i As Integer

Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.AllowMultiSelect = True
.FilterIndex = 2
.Title = "Select Excel File(s)"
.InitialFileName = ""

If .Show = -1 Then
ReDim selectedPaths(.SelectedItems.Count - 1)

For i = 0 To .SelectedItems.Count - 1
selectedPaths(i) = .SelectedItems(i + 1)
MsgBox .SelectedItems(i + 1)
Next i
End If
.Execute     'Open selected files
End With
Set fd = Nothing
End Sub

 

[halit3]

kodun yöntemini değiştirdim.

'referanslar
'Microsoft Word 12.0 Object Library

#If Win64 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function CloseClipboard& Lib "user32" ()
#End If
Dim bulunan2

Sub tablo_word1()

Dim fd As FileDialog
Dim i As Integer
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = True
fd.FilterIndex = 1
fd.Title = "Dosya Açma Penceresi"
fd.InitialFileName = ThisWorkbook.Path
If fd.Show = -1 Then
yol = fd.SelectedItems(1)


Rows("2:2").RowHeight = 48
Columns("B:B").ColumnWidth = 15

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Picture.Type = 13 Then
'If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture


Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape

Set objWord = CreateObject("Word.Application")
objWord.Visible = True



Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
Application.WindowState = wdWindowStateMinimize

Dim son
sat = 1
say1 = 2



If objWord.ActiveDocument.Tables.Count > 0 Then
aranan = "Tür / Species"
satson = objWord.ActiveDocument.Tables(1).Rows.Count
sutson = objWord.ActiveDocument.Tables(1).Columns.Count

For r = 1 To objWord.ActiveDocument.Tables(1).Rows.Count
bulunan = objWord.ActiveDocument.Tables.Item(1).Cell(r, 1).Range.Text

k = InStr(1, bulunan, aranan)
If k > 0 Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(1).Cell(r, 2).Range.Text, "", "")
ThisWorkbook.Sheets("Sayfa1").Cells(1, 2).Value = bulunan2
End If
Next r
End If


For Each ImgItem In docWord.InlineShapes
iCnt = iCnt + 1

If ImgItem.Type = wdInlineShapePicture Then
ImgItem.Select
objWord.Selection.CopyAsPicture
End If
Next

ThisWorkbook.Sheets("Sayfa1").Cells(2, 2).Select
ThisWorkbook.ActiveSheet.Paste

Set Adres = ThisWorkbook.Sheets("Sayfa1").Cells(20, 2).Cells

Set s1 = ThisWorkbook.Sheets("Sayfa1")
saymm = s1.Shapes.Count
Set Adres = s1.Cells(2, 2).Cells
ad1 = s1.Shapes(saymm).Name
s1.Shapes(ad1).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad1).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad1).OLEFormat.Object.Height = Adres.Height
s1.Shapes(ad1).OLEFormat.Object.Width = Adres.Width
s1.Shapes(ad1).OLEFormat.Object.Name = bulunan2


OpenClipboard (0&)
EmptyClipboard
CloseClipboard

docWord.Close SaveChanges:=wdPromptToSaveChanges 'SaveChanges:=False

objWord.Quit
Set docWord = Nothing

dosyaolustur

MsgBox "işlem tamam"

Else
MsgBox "Dosya seçilmedi"
End If
Set fd = Nothing

End Sub


Sub dosyaolustur()

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

yol = ThisWorkbook.Path & "\"
sayi = 3
   
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

Dim ImgItem As Word.InlineShape
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True


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

'If msg1 = vbYes Then
'.Orientation = wdOrientPortrait
'yükseylik = 189
'Else
.Orientation = wdOrientLandscape
yükseylik = 230
'End If

End With

With wrdApp.ActiveDocument

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, 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 With

ekle1 = 0
sat = 0
say = 0


Set s1 = Sheets("Sayfa1")
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

If Picture.Name = bulunan2 Then
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
's2.Paste Destination:=s2.Range("O2")
Exit For
End If
End If
Next Picture



For s = 1 To 6
say = say + 1
If say Mod sayi = 1 Then
sut = 1
sat = sat + 1 + ekle1
ekle1 = 1
son = wrdApp.ActiveDocument.Tables(1).Rows.Count ' satır kontrol
If wrdApp.ActiveDocument.Tables.Count >= 1 Then
If say > 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
End If
Else
sut = sut + 1
End If

wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range = bulunan2

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 = yükseylik
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

Next


klasor = ThisWorkbook.Path & "\yeni"

If CreateObject("Scripting.FileSystemObject").FolderExists(klasor) = False Then
MkDir klasor
End If

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

ThisWorkbook.Application.WindowState = xlNormal
Cells(1, 1).Select
'wrdApp.Documents(wrdDoc.Name).Activate
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End Sub

 

[hadromer]

kodun yöntemini değiştirdim.

'referanslar
'Microsoft Word 12.0 Object Library

#If Win64 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function CloseClipboard& Lib "user32" ()
#End If
Dim bulunan2

Sub tablo_word1()

Dim fd As FileDialog
Dim i As Integer
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = True
fd.FilterIndex = 1
fd.Title = "Dosya Açma Penceresi"
fd.InitialFileName = ThisWorkbook.Path
If fd.Show = -1 Then
yol = fd.SelectedItems(1)


Rows("2:2").RowHeight = 48
Columns("B:B").ColumnWidth = 15

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Picture.Type = 13 Then
'If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture


Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape

Set objWord = CreateObject("Word.Application")
objWord.Visible = True



Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
Application.WindowState = wdWindowStateMinimize

Dim son
sat = 1
say1 = 2



If objWord.ActiveDocument.Tables.Count > 0 Then
aranan = "Tür / Species"
satson = objWord.ActiveDocument.Tables(1).Rows.Count
sutson = objWord.ActiveDocument.Tables(1).Columns.Count

For r = 1 To objWord.ActiveDocument.Tables(1).Rows.Count
bulunan = objWord.ActiveDocument.Tables.Item(1).Cell(r, 1).Range.Text

k = InStr(1, bulunan, aranan)
If k > 0 Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(1).Cell(r, 2).Range.Text, "", "")
ThisWorkbook.Sheets("Sayfa1").Cells(1, 2).Value = bulunan2
End If
Next r
End If


For Each ImgItem In docWord.InlineShapes
iCnt = iCnt + 1

If ImgItem.Type = wdInlineShapePicture Then
ImgItem.Select
objWord.Selection.CopyAsPicture
End If
Next

ThisWorkbook.Sheets("Sayfa1").Cells(2, 2).Select
ThisWorkbook.ActiveSheet.Paste

Set Adres = ThisWorkbook.Sheets("Sayfa1").Cells(20, 2).Cells

Set s1 = ThisWorkbook.Sheets("Sayfa1")
saymm = s1.Shapes.Count
Set Adres = s1.Cells(2, 2).Cells
ad1 = s1.Shapes(saymm).Name
s1.Shapes(ad1).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad1).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad1).OLEFormat.Object.Height = Adres.Height
s1.Shapes(ad1).OLEFormat.Object.Width = Adres.Width
s1.Shapes(ad1).OLEFormat.Object.Name = bulunan2


OpenClipboard (0&)
EmptyClipboard
CloseClipboard

docWord.Close SaveChanges:=wdPromptToSaveChanges 'SaveChanges:=False

objWord.Quit
Set docWord = Nothing

dosyaolustur

MsgBox "işlem tamam"

Else
MsgBox "Dosya seçilmedi"
End If
Set fd = Nothing

End Sub


Sub dosyaolustur()

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

yol = ThisWorkbook.Path & "\"
sayi = 3
  
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

Dim ImgItem As Word.InlineShape
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True


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

'If msg1 = vbYes Then
'.Orientation = wdOrientPortrait
'yükseylik = 189
'Else
.Orientation = wdOrientLandscape
yükseylik = 230
'End If

End With

With wrdApp.ActiveDocument

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, 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 With

ekle1 = 0
sat = 0
say = 0


Set s1 = Sheets("Sayfa1")
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

If Picture.Name = bulunan2 Then
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
's2.Paste Destination:=s2.Range("O2")
Exit For
End If
End If
Next Picture



For s = 1 To 6
say = say + 1
If say Mod sayi = 1 Then
sut = 1
sat = sat + 1 + ekle1
ekle1 = 1
son = wrdApp.ActiveDocument.Tables(1).Rows.Count ' satır kontrol
If wrdApp.ActiveDocument.Tables.Count >= 1 Then
If say > 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
End If
Else
sut = sut + 1
End If

wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range = bulunan2

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 = yükseylik
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

Next


klasor = ThisWorkbook.Path & "\yeni"

If CreateObject("Scripting.FileSystemObject").FolderExists(klasor) = False Then
MkDir klasor
End If

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

ThisWorkbook.Application.WindowState = xlNormal
Cells(1, 1).Select
'wrdApp.Documents(wrdDoc.Name).Activate
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End Sub

sizlere zahmet veriyorum, teşekkür ederim. Aşağıda gif ekledim. Söylediğiniz gibi güncel kodu denedim ekrandaki hatayı alıyorum.

 

[halit3]

ben genelde bunu yapmam ama bir istisna olsun teamwier ile bağlanabilirim tabi isterseniz özel mesajdan gerekli kullanıcı isim ve giriş kodlarını tabi verirseniz.