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 wdDocs As Word.Documents
Dim wdDoc As Word.Document
Dim wdImage As Object
Dim wdTable As Word.Table
Dim wdPrps As Object
Dim wdPrp As Object
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim objPDF_Distiller As PdfDistiller
' strings
Dim strBackSql As String
Dim strTest As String
Dim strImageFile As String
Dim strSubPDFFolder As String
Dim strTitleName As String
Dim strWordSourceFile As String
Dim strWordBlankFile As String
Dim strWordResultFile As String
Dim strPDFfile As String
Dim strPSfile As String
Dim strLOGfile As String
Dim strSourceFullPath As String
Dim strBlankFullPath As String
Dim strResultFullPath 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 lngPos As Long
Dim lngResult As Long
Dim lngTablePos As Long
' integers
Dim intTableCount As Integer 'GLS
Dim intRecordNumber As Integer 'GLS
' booleans
Dim blnBackGoodIO As Boolean
Set db = CurrentDb()
'=================================================
' return msgbox of number of Checked Students detected
'=================================================
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 students to process"
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
' ============================
' set record source to retrieve checked students
' ============================
Call q925_set_sql_rst_CHECKBOXES _
(strTableName_Students, _
strBackSql)
Set rst = db.OpenRecordset(strBackSql)
strrst = "y"
' ============================
' Calculate Word wdDoc to be retrieved and open it
' ============================
'set word wdDoc name
'note: if you change properties of FIELDS doc, than copy FIELDS doc to test doc
' delete everything from test doc, and then save it as BLANK doc
strWordSourceFile = "xxTemplate_Electives_EvaluationForm_FIELDS.doc"
strWordBlankFile = "xxTemplate_Electives_EvaluationForm_BLANK.doc"
strSourceFullPath = CurrentProject.Path & "\" & strWordSourceFile
strBlankFullPath = CurrentProject.Path & "\" & strWordBlankFile
strSubPDFFolder = "Evaluation_ for_Clerkship"
Debug.Print "Opening document based on strTemplate: " & strSourceFullPath
'Open Word
Set appWord = GetObject(, "Word.Application")
appWord.Visible = True
Set wdDocs = appWord.Documents
'Open blank "template" file
wdDocs.Open strBlankFullPath
Set wdDoc = appWord.ActiveDocument
'====
'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
intRecordNumber = intRecordNumber + 1
strTitleName = rst!S_Title
' insert page break after page 1
If intRecordNumber > 1 Then
wdDoc.Bookmarks("\EndOfDoc").Range.InsertBreak wdSectionBreakNextPage
End If
' insert source document into blank doc
wdDoc.Bookmarks("\EndOfDoc").Range.InsertFile strSourceFullPath 'GLS
' calculate number of tables in the document on the first page
If intRecordNumber = 1 Then 'GLS
intTableCount = wdDoc.Tables.Count 'GLS
Debug.Print wdDoc.Tables.Count 'GLS
End If 'GLS
Debug.Print rst!S_Lname & " " & rst!S_Fname; " " & rst!S_Id
' ======================
' display Properties for testing purposes
' ======================
Set wdPrps = wdDoc.CustomDocumentProperties 'GLS
For Each wdPrp In wdPrps
Debug.Print wdPrp.Name & " : " & wdPrp.Value
Next
' ======================
' populate Properties and update document
' ======================
With wdPrps
.Item("w_a_StudentName").Value = rst!S_Lname & ", " & rst!S_Fname
.Item("w_b_Subject").Value = rst!S_Subject
.Item("w_c_CourseTitle").Value = rst!S_Title
.Item("w_d_CourseNumber").Value = rst!S_Course_Number
.Item("w_e_CAD").Value = rst!S_Advisor_Lname & ", " & rst!S_Advisor_Fname
.Item("w_f_StartDate").Value = rst!S_StartDate
.Item("w_g_EndDate").Value = rst!S_EndDate
.Item("w_h_InstructorName").Value = rst!S_Instructor_Fname & " " & rst!S_Instructor_Lname
.Item("w_i_StreetLine1").Value = rst!S_street1
.Item("w_j_StreetLine2").Value = rst!S_street2
' .Item("w_k_StreetLine3").Value = rst!S_street3
.Item("w_l_City").Value = rst!S_city
.Item("w_m_State").Value = rst!S_state
.Item("w_n_Zip").Value = rst!S_zip
.Item("w_o_CRN").Value = rst!S_CRN
End With
' ======================
' update Properties and convert to text, so that props cannot be re-updated
' ======================
wdDoc.fields.Update 'GLS
wdDoc.fields.Unlink 'GLS convert fields to text
'========================
' position to first element of table to insert picture
'========================
' add in line image
strImageFile = "O:\COM Photos\MED Pics Banner\" & _
rst!S_Id & ".jpg"
If dir(strImageFile) <> "" Then
Else
strImageFile = "O:\COM Photos\MED Pics Banner\" & _
"a_missingPhoto.jpg"
End If
'http://www.experts-exchange.com/Microsoft/Development/MS_Access/Access_Coding-Macros/Q_23702385.html?sfQueryTermInfo=1+cell+imag+insert+tabl+word
' calculate table position for new page, otherwise will keep inserting picture into
' the first table on the first page
lngTablePos = 1 + intTableCount * (intRecordNumber - 1)
Set wdTable = wdDoc.Tables(lngTablePos) 'GLS
' insert picture into the 1st element of the table
wdDoc.Range.InlineShapes.AddPicture strImageFile, _
False, True, wdTable.Cell(1, 1).Range
nextrec:
rst.MoveNext
Loop
'======================
' save as word doc file
'======================
strWordResultFile = Format(Date, "YYYY_MM_DD") & "_" & strTitleName & ".doc"
strResultFullPath = CurrentProject.Path & "\" & strWordResultFile
'* Delete the existing file
If dir(strResultFullPath) <> "" Then
Kill (strResultFullPath)
End If
wdDoc.SaveAs strResultFullPath
'=========================
' save as pdf file if Adobe is on the pc
'=========================
If IsAdobeInstalled = True Then
' save default printer settings
pg_strDefaultPrinter = appWord.ActivePrinter
' Create PS, LOG, PDF file names from Excel file name
lngPos = InStr(strResultFullPath, ".")
strPSfile = Left(strResultFullPath, lngPos) & "ps"
strLOGfile = Left(strResultFullPath, lngPos) & "log"
strPDFfile = Left(strResultFullPath, lngPos) & "pdf"
Debug.Print strPSfile
Debug.Print strLOGfile
Debug.Print strPDFfile
' override default printer with Adobe printer
appWord.ActivePrinter = "Adobe PDF on LPT2:"
' remember to set: Tools/references Acrobat distiller
Set objPDF_Distiller = New PdfDistiller
' print is really an export to pdf
appWord.PrintOut , Copies:=1, _
PrintToFile:=True, OutputFileName:=strPSfile
' Convert Acrobat PS file to PDF file
lngResult = objPDF_Distiller.FileToPDF(strPSfile, strPDFfile, "")
' delete work files
Kill strPSfile
Kill strLOGfile
Set objPDF_Distiller = Nothing
' Restore the default printer settings
appWord.ActivePrinter = pg_strDefaultPrinter
End If
wdDoc.Close savechanges:=False
appWord.Quit
finishup:
If strrst = "y" Then
rst.Close
End If
db.Close
Set appWord = Nothing
Set wdDocs = Nothing
Set wdDoc = Nothing
Set wdImage = Nothing
Set wdTable = Nothing
Set wdPrps = Nothing
Set wdPrp = Nothing
Set objPDF_Distiller = 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
Public Function IsAdobeInstalled() As Boolean
Dim strTemp As String
IsAdobeInstalled = False
strTemp = dir("C:\Program Files\Adobe\acrobat*", vbDirectory)
Do Until strTemp = ""
IsAdobeInstalled = True
strTemp = dir()
Loop
End Function
|
