#1
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Path = CurrentProject.Path & "\Ödeme Takibi Uygulaması\Master Dosyalar\TL HESABI.docx"
Set doc = appword.Documents.Open(Path, , True)
With doc
.Bookmarks("txtalici").Range.Text = Me.Alıcı
appword.Visible = True
appword.Activate
End With
Set doc = Nothing
Set appword = Nothing If MsgBox("D İ K K A T" & Chr(13) & _
"Bilgiler Şablona Yazdırılacak. Onaylıyor musunuz?", vbInformation + vbOKCancel) = vbOK Then
Else
Exit Sub
End If
Dim rs As New ADODB.Recordset
Dim objWord As Word.Application 'word programı
Dim objDocument As Object 'word belgesi
Dim objselection As Object
Dim objtable As Word.Table
Dim objrange As Word.Range
DoCmd.OpenQuery "S_RISK"
Set objWord = New Word.Application
objWord.Visible = True 'word programını görünür hale getiriyoruz.
Set objDocument = objWord.Documents.Add
Set objselection = objWord.Selection()
objWord.Selection.Font.Size = 12 'Yazı Büyüklüğü
objWord.Selection.Paragraphs.SpaceAfter = 0
objWord.Selection.Paragraphs.SpaceBefore = 0
objWord.Selection.Font.Name = (Arial) ' Yazı Karakteri
With objWord.Selection
.TypeText (Me.Detay)
.Font.Bold = True
Set WordApp = Nothing
End With
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim i As Integer
Dim intRecords As Integer
Dim intColumns As Integer
strSQL = "qryTest"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.EOF = True Then
MsgBox "No records were retrieved. Cannot continue.", vbCritical, "Request Aborted"
rs.Close
Set db = Nothing
Exit Sub
End If
'lets get some counts
rs.MoveLast
intRecords = 0
intRecords = rs.RecordCount
Debug.Print "rs.RecordCount = " & intRecords
'Name the Range for the data added
intRecords = intRecords + 1 'add one row for the header names
'lets see how many columns we have
intColumns = 0
intColumns = rs.Fields.Count
'*************************************
Dim myWordApp As Word.Application
Dim docNew As Word.Document
Dim docTable As Word.Table
Set myWordApp = CreateObject("Word.Application")
myWordApp.Visible = True
Set docNew = myWordApp.Documents.Open("C:\Test\WordDocFolder\TestMailMerge.docx")
'Create a table that has the correct number of cells
docNew.Tables.Add Range:=docNew.Range(Start:=0, End:=0), NumRows:=intRecords, NumColumns:=intColumns
Set docTable = docNew.Tables(1)
'Get some header names in the first Row
For i = 1 To rs.Fields.Count
docTable.Cell(1, i).Range.Text = rs.Fields(i - 1).Name
Next i
rs.MoveLast
While rs.BOF = False
'Populate the last row
For i = 1 To rs.Fields.Count
If Not IsNull(rs.Fields(i - 1).Value) Then
docTable.Cell(intRecords, i).Range.Text = rs.Fields(i - 1).Value
End If
Next i
Debug.Print intRecords
intRecords = intRecords - 1
rs.MovePrevious
Wend
docNew.Save
docNew.Close
myWordApp.Quit
Set docNew = Nothing
Set myWordApp = Nothing