Private Sub CommandButton11_Click()
'Tüm Personelin Bilgi Formunu Dök
On Error GoTo ErrHandler
Dim wd As Word.Application
Dim wdDoc As Word.Document
Dim wrdPic As Word.InlineShape
Dim ImgName As String, fldName As String
Dim xlSht As Worksheet
Dim MyConn As String
Dim rst As ADODB.Recordset
Dim i As Integer, j As Integer, intRec As Integer
Dim arrVal As Variant
MyConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source= " & ThisWorkbook.Path & "\VT.mdb"
Set rst = New ADODB.Recordset
rst.Open "personel", MyConn, adOpenStatic, adLockReadOnly
intRec = rst.RecordCount
arrVal = rst.GetRows(intRec)
On Error Resume Next
Set wd = New Word.Application
With wd
.Visible = False
.ScreenUpdating = False
End With
For i = 0 To (intRec - 1)
ImgName = ThisWorkbook.Path & "\Resimler\" & arrVal(1, i) & ".jpg"
Set wdDoc = wd.Documents.Add(ThisWorkbook.Path & "\sablon.dotx")
With wdDoc
For j=1 to 100
fldName=rst.Fields(j).Name
.Bookmarks(fldName).Range.Text = arrVal(1, i)
Next j
If Dir(ImgName) <> "" Then
Set wrdPic = .Bookmarks("Img").Range.InlineShapes.AddPicture(Filename:=ImgName, LinkToFile:=False, SaveWithDocument:=True)
wrdPic.Height = 200
wrdPic.Width = 200
End If
.SaveAs2 Filename:="F:\PTS\PBF" & "\" & arrVal(4, i) & ".docx", FileFormat:=wdFormatXMLDocument
'.SaveAs2 Filename:="C:\Users\iambarkutuk\Desktop\PTS\PBF " \ " & arrVal(1, i) & arrVal(4, i) .docx", FileFormat:=wdFormatXMLDocument
'.SaveAs2 Filename:="D:\BELGE\ " & "\" & arrVal(4, i) & ".docx", FileFormat:=wdFormatXMLDocument
.Close
End With
Next i
With wd
.ScreenUpdating = True
.Quit
End With
ErrExit:
Set wd = Nothing
Set wdDoc = Nothing
Exit Sub
ErrHandler:
wd.Quit
Set wd = Nothing
Set wdDoc = Nothing
Set wrdPic = Nothing
End Sub
