Dim oWordDoc As Word.Document
Dim oWord As Word.Application
Dim sDocument As String
Dim i, a, GVeriSayisi As Integer
Dim qdf As QueryDef
Dim rs As Recordset
sDocument = CurrentProject.Path & "\Risk Raporu.docx"
If FileExists(sDocument) Then
Kill sDocument
End If
Set oWord = CreateObject("Word.Application")
Set oWordDoc = oWord.Documents.Add
oWordDoc.SaveAs sDocument
oWord.Visible = True
oWord.WindowState = 1
DoEvents
oWord.Activate
oWordDoc.Sections.PageSetup.Orientation = wdOrientLandscape
oWordDoc.Sections.PageSetup.LeftMargin = InchesToPoints(0.75)
oWordDoc.Sections.PageSetup.RightMargin = InchesToPoints(0.1)
oWordDoc.Sections.PageSetup.TopMargin = InchesToPoints(0.3)
oWordDoc.Sections.PageSetup.BottomMargin = InchesToPoints(0.2)
i = 1
Set qdf = CurrentDb.QueryDefs("sorgu_rapor")
qdf![Forms!frm_degerlendir!mtn_pıd] = [Forms]![frm_degerlendir]![mtn_pıd]
Set rs = qdf.OpenRecordset()
rs.MoveLast
rs.MoveFirst
GVeriSayisi = rs.RecordCount
If GVeriSayisi <> 0 Then
Do Until rs.EOF = True
oWord.Selection.Font.Bold = True
oWord.Selection.Font.Size = "24"
oWord.Selection.Paragraphs.Alignment = WdParagraphAlignment.wdAlignParagraphCenter
oWord.Selection.TypeText "TESPİT EDİLEN RİSK VE AÇIKLAMASI"
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=6, NumColumns:= _
3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
Set oWordTbl = oWordDoc.Tables(i)
oWordTbl.Cell(1, 1).Select
oWord.Selection.Font.Size = "9"
oWordTbl.Rows(1).Height = "0.5"
oWord.Selection.TypeText "TESPİT EDİLEN RİK KONUSU"
oWord.Selection.Paragraphs.Alignment = WdParagraphAlignment.wdAlignParagraphLeft
oWordTbl.Cell(3, 1).Select
oWord.Selection.Font.Size = "9"
oWordTbl.Rows(3).Height = "0.5"
oWord.Selection.TypeText "TESPİT EDİLEN RİSK DURUMU"
oWord.Selection.Paragraphs.Alignment = WdParagraphAlignment.wdAlignParagraphLeft
oWordTbl.Cell(5, 1).Select
oWord.Selection.Font.Size = "9"
oWordTbl.Rows(5).Height = "0.5"
oWord.Selection.TypeText "TESPŞT EDİLEN RİSK İLE İLGİLİ AÇIKLAMA"
oWord.Selection.Paragraphs.Alignment = WdParagraphAlignment.wdAlignParagraphLeft
oWordTbl.Rows(6).HeightRule = wdRowHeightExactly
oWordTbl.Rows(6).Height = 99
oWordTbl.Columns(1).Width = "12.75"
oWordTbl.Columns(2).Width = "7.5"
oWordTbl.Columns(3).Width = "7.5"
GResimYolu = Nz(rs!txtresim1.Value, "")
GResimYolu2 = Nz(rs!txtresim2.Value, "")
GResimYolu3 = Nz(rs!txtresim3.Value, "")
GResimYolu4 = Nz(rs!txtresim4.Value, "")
If Len(GResimYolu) > 0 And FileExists(GResimYolu) = True Then
oWordTbl.Cell(1, 2).Select
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=1, NumColumns:= _
1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
Set newPicture = oWord.Selection.InlineShapes.AddPicture(FileName:=GResimYolu, LinkToFile:=True, SaveWithDocument:=True)
newPicture.Height = 150
newPicture.Width = 100
End If
If Len(GResimYolu2) > 0 And FileExists(GResimYolu2) = True Then
oWordTbl.Cell(1, 3).Select
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=1, NumColumns:= _
1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
Set newPicture = oWord.Selection.InlineShapes.AddPicture(FileName:=rs!txtresim2.Value, LinkToFile:=True, SaveWithDocument:=True)
newPicture.Height = 150
newPicture.Width = 100
End If
oWordTbl.Cell(Row:=1, Column:=2).Merge _
MergeTo:=oWordTbl.Cell(Row:=6, Column:=2)
oWordTbl.Cell(Row:=1, Column:=3).Merge _
MergeTo:=oWordTbl.Cell(Row:=6, Column:=3)
oWordTbl.Cell(2, 1).Select
oWord.Selection.Font.Size = "12"
oWord.Selection.TypeText Nz(rs!SORU.Value, "")
oWordTbl.Cell(4, 1).Select
oWord.Selection.Font.Size = "12"
oWord.Selection.TypeText Nz(rs!TESDUR.Value, "")
oWordTbl.Cell(6, 1).Select
oWord.Selection.Font.Size = "12"
oWord.Selection.TypeText Nz(rs!TESACIK.Value, "")
oWordTbl.Select
oWord.Selection.Collapse WdCollapseDirection.wdCollapseEnd
oWord.Selection.Paragraphs.Alignment = WdParagraphAlignment.wdAlignParagraphCenter
oWord.Selection.TypeText "TESPİT EDİLEN RİSK KONUSU ÖNERİSİ"
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=1, NumColumns:= _
3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
a = i + 1
Set oWordTbl = oWordDoc.Tables(a)
If Len(GResimYolu3) > 0 And FileExists(GResimYolu3) = True Then
oWordTbl.Cell(1, 2).Select
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=1, NumColumns:= _
1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
Set newPicture = oWord.Selection.InlineShapes.AddPicture(FileName:=GResimYolu3, LinkToFile:=False, SaveWithDocument:=True)
newPicture.LockAspectRatio = msoTrue
newPicture.Height = 150
newPicture.Width = 100
End If
If Len(GResimYolu4) > 0 And FileExists(GResimYolu4) = True Then
oWordTbl.Cell(1, 3).Select
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=1, NumColumns:= _
1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
Set newPicture = oWord.Selection.InlineShapes.AddPicture(FileName:=GResimYolu4, LinkToFile:=False, SaveWithDocument:=True)
newPicture.LockAspectRatio = msoTrue
newPicture.Height = 150
newPicture.Width = 100
End If
oWordTbl.Cell(3, 1).Select
oWord.Selection.Font.Size = "12"
oWord.Selection.TypeText Nz(rs!ONACIK.Value, "")
oWordTbl.Select
oWord.Selection.Collapse WdCollapseDirection.wdCollapseEnd
'If GVeriSayisi <> i Then
oWord.Selection.InsertBreak Type:=wdPageBreak
'End If
i = i + 2
' Exit Sub
rs.MoveNext
Loop
End IfAyrıca, kodda tasarım değişikliği yapmadım ancak bu şekilde kod yazılmaz kod nerede başlıyor, nerede bitiyor belli değil, kodları belirli düzen içerisinde yazmalısın.
