Grupta istenen eleman yok hatası

[hadromer]

kod resim ve adını bazen eşliştirmiyor.

tamam hocam. Şimdilik bende bir problem görünmüyor

 

[hadromer]

@halit3 hocam oluşturduğumuz yeni dosya içerisindeki fotoğrafları altındaki isme göre alfabetik sıralatabilir miyiz ? bunun için nasıl bir yol izlemem gerekiyor

 

[halit3]

alfabetik sıralama yapılamaz

 

[halit3]

Bu kod da resim isimlerindeki kaymalar önlendi
Örnek d5.docx dosyasında 91 ve 162 sayfalarda iki adet resim olduğundan isimlerde kaymalar oluyordu kod iki resim olan hücrelerde sadece birincisini görüp işlem yapıyor.

'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme6()
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 = 220 '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
ReDim veri(5000)
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)


sayy1 = 0

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
If objWord.ActiveDocument.Tables(1).Rows.Count > 2 Then
For r = 2 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 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(i).Cell(r, 2).Range.Text, "", ""), Chr(13), ""))
sayy1 = sayy1 + 1
Cells(sayy1, 2) = bulunan2
veri(sayy1) = bulunan2
GoTo atla3
End If
Next r
End If
atla3:
Next i
End If


'On Error Resume Next
sat2 = 1
deg2 = 0

deg3 = 0
deg4 = 0

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
deg3 = objWord.Selection.Paragraphs.Last.Range.End
If deg3 < deg4 + 50 Then GoTo atla8

deg2 = deg2 + 1
Cells(deg2, 3) = veri(deg2)

wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = veri(deg2)
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

objWord.Selection.CopyAsPicture

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

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
atla8:
deg4 = objWord.Selection.Paragraphs.Last.Range.End

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

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing
'say = say + 1
'ThisWorkbook.Sheets(ActiveSheet.Name).Cells(say, 2).Value = dosya.Name
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

 

[halit3]

Resimleri sıralamak için farklı bir yöntem denedim iki aşamalı bu yöntem
1- klasore_kayıtyap makrosu sayfanın hemen yanına Resimler klasörü açıyor ve word dosyasındaki resimleri buraya kayıt yapıyor.

'referanslar
'Microsoft Word 12.0 Object Library
Dim deg8
#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

#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

#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
Private 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 & "\Resimler"

If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor) = False Then
MkDir Klasor
End If
son1 = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & deg8 & " " & Format(son1, "000000") & ".jpg"

SavePicture IPic, dosya_adi '"c:\xxx.bmp"

Set IPic = Nothing
End Sub

Sub klasore_kayıtyap()
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")


Application.WindowState = wdWindowStateMinimize

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

yol = dosya
ReDim veri(5000)
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)

sayy1 = 0

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
If objWord.ActiveDocument.Tables(1).Rows.Count > 2 Then
For r = 2 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(Replace(Replace(Trim(objWord.ActiveDocument.Tables.Item(i).Cell(r, 2).Range.Text), "", ""), Chr(13), ""), Chr(32), "")
sayy1 = sayy1 + 1
If Mid(bulunan2, 1, 1) = " " Then bulunan2 = Mid(bulunan2, 2, 500)
If IsNumeric(1 & Mid(bulunan2, 1, 1)) = True Then bulunan2 = Mid(bulunan2, 2, 500)
veri(sayy1) = bulunan2
GoTo atla3
End If
Next r
End If
atla3:
Next i
End If

'On Error Resume Next
deg3 = 0
deg4 = 0
deg2 = 0

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
ImgItem.Select
deg3 = objWord.Selection.Paragraphs.Last.Range.End
If deg3 < deg4 + 50 Then GoTo atla8
deg2 = deg2 + 1
Cells(deg2, 3) = veri(deg2)
deg8 = veri(deg2)
objWord.Selection.CopyAsPicture
Call ImageToMePicture

'----------------------------------------------------
atla8:
deg4 = objWord.Selection.Paragraphs.Last.Range.End
'-------------------------------------------------------
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

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

2-worde_kayıtyap makrosuda Resimler klasöründeki kayıtlı resimlerle word dosyası oluşturuyor.

'referanslar
'Microsoft Word 12.0 Object Library

Sub worde_kayıtyap()
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 = 220 '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 = "jpg" Or uzanti = "bmp" Then
veri = dosya
veri3 = dosya.Name
veri2 = Mid(dosya.Name, 1, Len(veri3) - 10)

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)

.Range.Paragraphs.WordWrap = True
.Range.InlineShapes.AddPicture Filename:=veri, 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 = yuk '200
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6 '285 '250
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = veri2

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

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

 

[hadromer]

@halit3 ben artık size nasıl teşekkür edeceğimi bilemiyorum. Allah ne muradınız varsa versin daha önce bir konunuza denk geldim, kalsörden word dosyasına fotoğraf alma kodu yazmışsınız o da çok kullanışlıydı elinize kolunuza sağlık hocam