- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,852
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Makro ile word dosyasına klasördeki resimleri eklemek ile ilgili çalışma
kod:
kod:
Kod:
Dim klasor2(50000)
Dim saydır
Sub worde_resim_al()
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
saydır = 0
Liste (Kaynak)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
sayi = Application.InputBox("Kaç adet sütun eklenecek.", "Sayı giriniz.", "2", 400, 30, , Type:=1)
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
msg1 = MsgBox("Sayfayı DİKEY yapmak için EVET tıklayınız. " & Chr(10) & Chr(10) & _
"Sayfayı YATAY yapmak için HAYIR tıklayınız.", vbYesNo + vbInformation, "u y a r ı !")
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
If msg1 = vbYes Then
.Orientation = wdOrientPortrait
yükseylik = 189
Else
.Orientation = wdOrientLandscape
yükseylik = 175
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
For i = 1 To saydır
For Each Dosya In fL.getfolder(klasor2(i)).Files
If LCase(fL.GetExtensionName(Dosya)) = "jpg" Or LCase(fL.GetExtensionName(Dosya)) = "bmp" Then
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
With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut)
.Range = fL.GetBaseName(Dosya)
End With
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
End If
Next
Next
End With
son1 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
End With
wrdApp.Documents(wrdDoc.Name).Activate
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
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
saydır = saydır + 1
klasor2(saydır) = yol
sonraki:
For Each f In fL.getfolder(yol).subfolders
Liste (f.Path)
On Error GoTo sonraki
Next
End SubEkli dosyalar
Son düzenleme: