Option Compare Database
Option Explicit
Public Sub cmdWordEvaluations_Click_CHECKBOXES(strTableName_Students As String, _
strBackLabelStatus As Boolean)
On Error GoTo ErrorHandler
' objects
Dim appWord As Word.Application
Dim docs As Word.Documents
Dim ilImage As Object
Dim dTable As Word.Table
Dim prps As Object
Dim prp As DocumentProperty
Dim db As DAO.Database
Dim rst As DAO.Recordset
' strings
Dim strBackSql As String
Dim strTest As String
Dim strImageFile As String
Dim strSubPDFFolder As String
Dim strTemplateDir As String
Dim strWordFile As String
Dim strPDFFile As String
Dim strFullPath As String
Dim strMsg As String
Dim strrst As String
' longs
Dim lngCount As Long
Dim lngResponse As Long
Dim lngWordCount As Long
Dim lngBegCount As Long
Dim lngBackRowCount As Long
Dim blnBackGoodIO As Boolean
Set db = CurrentDb()
'=================================================
Call q823_Select_Table_Students_COUNT_Checkboxes _
(strTableName_Students, _
blnBackGoodIO, _
lngBackRowCount)
Debug.Print lngBackRowCount ' Recordset.Fields("ROWCOUNT") is the number of rows...
'=====================================================================
If lngBackRowCount = 0 Then
MsgBox "No records to export"
GoTo finishup
Else
strMsg = lngBackRowCount & _
" Evaluation Report(s) sending to Word"
strBackLabelStatus = True
lngResponse = MsgBox(strMsg, vbInformation + vbOKCancel + vbDefaultButton1, _
"Please be advised...")
If lngResponse = vbCancel Then
strBackLabelStatus = False
GoTo finishup
End If
End If
' ============================
Call q925_set_sql_rst_for_labels_CHECKBOXES _
(strTableName_Students, _
strBackSql)
Set rst = db.OpenRecordset(strBackSql)
strrst = "y"
' ============================
'Open Word
Set appWord = GetObject(, "Word.Application")
'Pick up Word user templates folder from Registry
strTest = appWord.Options.DefaultFilePath(wdUserTemplatesPath)
'set word doc name
strWordFile = "wClerkshipEvaluationForm_FIELDS.doc"
strFullPath = CurrentProject.Path & "\" & strWordFile
strSubPDFFolder = "Evaluation_ for_Clerkship"
Debug.Print "Opening document based on template: " & strFullPath
' open copy of template
Set docs = appWord.Documents
docs.Open strFullPath
'Set doc = appWord.ActiveDocument
appWord.Visible = True
'Loop through table, exporting each record to Word
' http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Word/Q_21152049.html?sfQueryTermInfo=1+selection.inlineshapes.addpictur
' http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Word/Q_23785214.html?sfQueryTermInfo=1+cell+popul+tabl+word
Do Until rst.EOF
Debug.Print rst!S_LName & " " & rst!S_FName; " " & rst!S_Id
' With appWord.ActiveDocument
' Set prps = .CustomDocumentProperties
' Set dTable = .Tables(1)
' End With
' similar to with/end with construct above
Set dTable = ActiveDocument.Tables(1)
Set prps = ActiveDocument.CustomDocumentProperties
' For Each prp In prps
' Debug.Print prp.Name & " : " & prp.Value
' Next
' ======================
' populate Properties and update document
' ======================
With prps
.Item("w_FullName").Value = rst!S_LName & ", " & rst!S_FName
.Item("w_Attrib").Value = "M3"
.Item("w_Clerkship").Value = "test clerkship"
.Item("w_Date_From").Value = vbNullString
.Item("w_Date_To").Value = vbNullString
End With
' i copied this from internet, not sure if i need it
' This will make sure all fields are updated when you open the file.
' It is also possible to update specific fields instead all.
With appWord.Selection
.WholeStory
.fields.Update
.MoveDown Unit:=wdLine, Count:=1
End With
'========================
' position to first element of table to insert picture
'========================
dTable.Select
Selection.MoveRight Unit:=wdCell, Count:=1
'As a test, Insert a literal into the table element that really holds the picture
Selection.Text = "Insert Picture Here"
' add in line image
strImageFile = "O:\COM Photos\MED Pics Banner\" & _
rst!S_Id & ".jpg"
Set ilImage = Selection.InlineShapes.AddPicture(strImageFile, _
LinkToFile:=False, _
SaveWithDocument:=True)
nextrec:
rst.MoveNext
Loop
appWord.Selection.HomeKey Unit:=wdStory
appWord.Activate
finishup:
If strrst = "y" Then
rst.Close
End If
db.Close
Set appWord = Nothing
Set docs = Nothing
Set ilImage = Nothing
Set dTable = Nothing
Set prps = Nothing
Set prp = Nothing
Set db = Nothing
Set rst = Nothing
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
|
