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

hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
halit3' Alıntı:
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.
Genişletmek için tıkla ...
halit bey çok ama çok teşekkür ederim hemen mesaj atıyorum size
 
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
@halit3 hocam bana çok yardımcı oldunuz. teşekkür ediyorum. Ana dosyaya gösterdiklerinizi uyguladım. Kod çalıştı, fakat sadece 6 tane fotoğraf aldı ve fotoğrafların hepsi de aynı. Ben tüm fotoları tek tek almasını istiyorum. ve sanırım 140-150 foto var
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
sorunuzu ben şöyle anladım örnek dosyanızda bir adet resim vardı onuda siz başka dosyaya 6 adet kapyalama yapmışsınız bizde bunu makro ile yaptık
 
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
halit3' Alıntı:
sorunuzu ben şöyle anladım örnek dosyanızda bir adet resim vardı onuda siz başka dosyaya 6 adet kapyalama yapmışsınız bizde bunu makro ile yaptık
Genişletmek için tıkla ...
hocam özür dilerim yanlış anlaşılmaya sebebiyet vermişim demek ki. ben örnek teşkil etmesi amacıyla tek fotoğraf kullanmıştım. ana dosyada farklı farklı türler var. her foto birbirinden farklı. Anlatmak istediğim buydu
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
şimdi şunu söyleyim bir klasörün içinde birden çok dosyamı var bu dosyaların her birinde bir adet resim mi var yoksa birden fazla resimmi var
 
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
halit3' Alıntı:
şimdi şunu söyleyim bir klasörün içinde birden çok dosyamı var bu dosyaların her birinde bir adet resim mi var yoksa birden fazla resimmi var
Genişletmek için tıkla ...
bir kalsörün içerisinde 6 tane dosya var. her bir dosyanın içerisinde de yüzlerce foto var. Ana dosyaları upload etmemi ister misiniz ?
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
evet örnek dosyalardan bir kaç tanesini gönder
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Tek dosya için bunu bir dene bütün dosyalar için kod yazmıyorum zira kopyala yapıştır belli bir yerden sonra donuyor.

Kod: 
'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 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

'Rows("2:2").RowHeight = 48
Columns("A:A").ColumnWidth = 43
Columns("A:A").ClearContents
Set s1 = Sheets(ActiveSheet.Name)

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


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
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
'Application.WindowState = wdWindowStateMinimize

Dim son
sat = 1
say1 = 2

sayy1 = 2
sayy2 = 2
sayy3 = s1.Shapes.Count + 1


If objWord.ActiveDocument.Tables.Count > 0 Then
For i = 1 To objWord.ActiveDocument.Tables.Count
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(i).Rows.Count
bulunan = objWord.ActiveDocument.Tables.Item(i).Cell(r, 1).Range.Text
k = InStr(1, bulunan, aranan)
If k > 0 Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(i).Cell(r, 2).Range.Text, "", "")
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(sayy1, 1).Value = bulunan2
sayy1 = sayy1 + 1
End If
Next r

Next i
End If

On Error Resume Next

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

If ImgItem.Type = wdInlineShapePicture Then

OpenClipboard (0&)
EmptyClipboard
CloseClipboard

If sayy3 Mod 10 = 1 Then

Application.Wait (Now + TimeValue("00:00:03"))
End If

ImgItem.Select
objWord.Selection.CopyAsPicture

ThisWorkbook.Sheets(ActiveSheet.Name).Paste Destination:=ThisWorkbook.Sheets(ActiveSheet.Name).Cells(sayy2, 4)

'ThisWorkbook.Sheets(ActiveSheet.Name).Cells(sayy2, 4).Select
'ThisWorkbook.ActiveSheet.Paste
Set Adres = ThisWorkbook.Sheets(ActiveSheet.Name).Cells(sayy2, 2).Cells
ad = sayy3

ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 2
ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 2
ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.Height = Adres.Height - 4
ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.Width = Adres.Width - 4
ThisWorkbook.ActiveSheet.Shapes(ad).OLEFormat.Object.Name = ad ' ThisWorkbook.Sheets(ActiveSheet.Name).Cells(sayy2, 1).Value

sayy3 = sayy3 + 1


sayy2 = sayy2 + 1
End If
Next

OpenClipboard (0&)
EmptyClipboard
CloseClipboard

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

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
sayi2 = Val(((Cells(Rows.Count, "A").End(3).Row - 1) * 2) / sayi) + 2
    
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:=sayi2, NumColumns:=sayi
Application.WindowState = wdWindowStateMinimize
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 = 1
say = 0
sut = 1

Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
'Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
'Set yer = s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column)
sat5 = Picture.TopLeftCell.Row


s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
's2.Paste Destination:=s2.Range("O2")
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range = Cells(sat5, 1)
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range.Select


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

sut = sut + 1
If sut = 4 Then
sut = 1
sat = sat + 2
'wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
'wrdApp.Selection.InsertRowsBelow 2
End If

End If
Next Picture
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

Application.WindowState = xlNormal
'wrdApp.Documents(wrdDoc.Name).Activate
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

For Each Picture In ActiveSheet.Shapes
If Picture.Type = 13 Then
Picture.Delete
End If
Next Picture


End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod isteneni tam yapıyor
word içeren klasörü seçmek yeterli sonuçları dosyanın hemen yanına yeni ismli bir klasor oluşturuyor ve içene kayıt yapıyor.

Kod: 
'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
Dim sat, sut

Dim wrdApp
Dim wrdDoc


Sub deneme1()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla



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

sat = 1
sut = 1
sayi = 3

  
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
.Orientation = wdOrientLandscape
yükseylik = 230
End With

With wrdApp.ActiveDocument
Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, NumColumns:=sayi
'Application.WindowState = wdWindowStateMinimize
End With

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
Application.WindowState = wdWindowStateMinimize

yol = Kaynak



For Each Dosya In fL.GetFolder(yol).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

ReDim deg1(5000)
sat2 = 0

yol = Dosya 'ThisWorkbook.Path & "\d1.doc"

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



If objWord.ActiveDocument.Tables.Count > 0 Then
ver1 = 0

For i = 1 To objWord.ActiveDocument.Tables.Count
aranan = "Tür / Species"
For r = 1 To objWord.ActiveDocument.Tables(i).Rows.Count
bulunan = objWord.ActiveDocument.Tables.Item(i).Cell(r, 1).Range.Text
k = InStr(1, bulunan, aranan)
If k > 0 Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(i).Cell(r, 2).Range.Text, "", "")

ver1 = ver1 + 1
deg1(ver1) = bulunan2
End If
Next r
Next i
End If


On Error Resume Next

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

If ImgItem.Type = wdInlineShapePicture Then

OpenClipboard (0&)
EmptyClipboard
CloseClipboard

ImgItem.Select
objWord.Selection.CopyAsPicture

'----------------------------------------------------

With wrdApp.ActiveDocument.PageSetup
yükseylik = 230
End With
sat2 = sat2 + 1
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range = deg1(sat2)
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut).Range.Select
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

sut = sut + 1
If sut = 4 Then
sut = 1
sat = sat + 2

wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2



End If
'-------------------------------------------------------

End If
Next



OpenClipboard (0&)
EmptyClipboard
CloseClipboard

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

objWord.Quit
Set docWord = Nothing

End If
Next

If sut = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
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


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
 

Ekli dosyalar

Son düzenleme:
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodu birazcık daha kısalttım.

Kod: 
'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

Sub deneme1()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

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

sat = 1
sut = 1
  
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
.Orientation = wdOrientLandscape
yükseylik = 230
End With

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, NumColumns:=3


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
Application.WindowState = wdWindowStateMinimize


For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

sat2 = 0
yol = Dosya

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)


'On Error Resume Next
deg1 = 1
For Each ImgItem In docWord.InlineShapes

If ImgItem.Type = wdInlineShapePicture Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(deg1).Cell(7, 2).Range.Text, "", "")
deg1 = deg1 + 2

ImgItem.Select
objWord.Selection.CopyAsPicture

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

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 = .Range.Cells.Width - 6
End With

sut = sut + 1
If sut = 4 Then
sut = 1
sat = sat + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------

End If
Next

OpenClipboard (0&)
EmptyClipboard
CloseClipboard


docWord.Close SaveChanges:=wdPromptToSaveChanges

objWord.Quit
Set docWord = Nothing

End If
Next

If sut = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
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


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
 
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
halit3' Alıntı:
Kodu birazcık daha kısalttım.

Kod: 
'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

Sub deneme1()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

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

sat = 1
sut = 1
 
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
.Orientation = wdOrientLandscape
yükseylik = 230
End With

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, NumColumns:=3


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
Application.WindowState = wdWindowStateMinimize


For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

sat2 = 0
yol = Dosya

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)


'On Error Resume Next
deg1 = 1
For Each ImgItem In docWord.InlineShapes

If ImgItem.Type = wdInlineShapePicture Then
bulunan2 = Replace(objWord.ActiveDocument.Tables.Item(deg1).Cell(7, 2).Range.Text, "", "")
deg1 = deg1 + 2

ImgItem.Select
objWord.Selection.CopyAsPicture

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

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 = .Range.Cells.Width - 6
End With

sut = sut + 1
If sut = 4 Then
sut = 1
sat = sat + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------

End If
Next

OpenClipboard (0&)
EmptyClipboard
CloseClipboard


docWord.Close SaveChanges:=wdPromptToSaveChanges

objWord.Quit
Set docWord = Nothing

End If
Next

If sut = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
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


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
Genişletmek için tıkla ...
@halit3 siz ne muhteşem bir insansınız. Hafta içi hafta sonu demediniz benim için uğraştınız. Kod muhteşem çalışıyor. Tam istediğim gibi. Çok teşekkür ediyorum. Elleriniz dert görmesin.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Teşekkürler iyi çalışmalar
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod birazcık daha kısa

Kod: 
'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme5()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

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

sat1 = 1
sut1 = 1
say1 = 3
yuk = 255 '165
  
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
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya

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)

'On Error Resume Next
sat2 = 1
deg2 = 1

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
sat2 = sat2 + 2
'objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
ImgItem.Select
objWord.Selection.CopyAsPicture
deg2 = deg2 + 1

'----------------------------------------------------
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = bulunan2
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.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 = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
 
Son düzenleme:
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
halit3' Alıntı:
Bu kod birazcık daha kısa

Kod: 
'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme5()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

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

sat1 = 1
sut1 = 1
say1 = 3
yuk = 255 '165
 
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
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya

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)

'On Error Resume Next
sat2 = 1
deg2 = 1

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
sat2 = sat2 + 2
objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
deg2 = deg2 + 1

'----------------------------------------------------
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = bulunan2
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.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 = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
Genişletmek için tıkla ...
@halit3 resmen kodlarla görsel şölen yapmaya devam ediyorsunuz :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst