M
MichaelBayne
I have been tasked to add to an existing program the ability to have
documents that are being exported from a program added to a new WinZip file.
Below is the script as/is. Can anyone direct me to how I can add what is
necessary to make this happen. If it is more than a generic line of code or
two, please assist me with the syntax... Thanks to anyone in advance that
may help. Not very familiar with Access just got pegged to be involved with
the process. The code below describes the exported docs and all of the
options involved in the export/
Private Sub btnRun_Click()
Const cFuncName = "DocumentExport_Run"
Dim boo1 As Boolean
Dim int1 As Integer
Dim intLockCount As Integer
Dim Handle As Integer
Dim lng1 As Long
Dim str1 As String
Dim var1 As Variant
Dim booAltereredDistiller As Boolean
Dim booDoThisOne As Boolean
Dim booSuccess As Boolean
Dim lngCount As Long
Dim lngTotal As Long
' Dim strDistillerSecurity As String
' Dim strDistillerObject As String
Dim strDocFile As String
Dim strDocFileShort As String
' Dim strFontName As String
' Dim strLogFile As String
Dim strOutFile As String
' Dim strPdfDevice As String
' Dim strPdfPort As String
' Dim strPdfPrinter As String
' Dim strPSFile As String
' Dim strSavePdfDocInfo As String
' Dim strSavePdfFileName As String
Dim strSavePrinter As String
Dim strSaveWordPrinter As String
'***> 4.3.20.0 (04/12/2001) - whn - Provide Task breakout in error handler
Dim strTask As String
' Dim typDS As obaDistillerSecurity
' Dim typSaveDS As obaDistillerSecurity
Dim typWm As obaWatermark
Dim dr As adh_tagDeviceRec
Dim rsWatermark As Recordset
Dim rsWork As Recordset
' Dim objDistiller As Object
Dim Word As Object
On Error GoTo ProcError
DoCmd.Hourglass True
Select Case Me!ogDocumentRange
Case Me!obSelected.OptionValue
' See if output file already exists
If Dir(Me!txtPath) <> "" Then
Beep
If MsgBox(Me!txtPath & " already exists." & vbCrLf & vbCrLf _
& "Do you want to overwrite it?", _
vbQuestion + vbYesNo + vbDefaultButton2, MsgBoxTitle("Document
Export")) <> vbYes Then
DoCmd.Hourglass False
Exit Sub
End If
End If
Case Else
' See if output path already has files in it
If Dir(FileName(Me!txtPath, "*.*")) <> "" Then
Beep
If MsgBox(Me!txtPath & " already contains some files. " _
& "This procedure will overwrite files of the same name." _
& vbCrLf & vbCrLf & "Do you want to continue?", _
vbQuestion + vbYesNo + vbDefaultButton2, MsgBoxTitle("Document
Export")) <> vbYes Then
DoCmd.Hourglass False
Exit Sub
End If
End If
End Select
Select Case Me.OpenArgs
Case "DocControl"
Set rsWork = Forms!DocCOntrol.RecordsetClone
Case "DocSearch"
Set rsWork = Forms!DocSearch!Docs.Form.RecordsetClone
End Select
If rsWork.BOF Then
Beep
MsgBox "Select at least one record before choosing EXPORT", vbCritical,
MsgBoxTitle(cFuncName)
DoCmd.Hourglass False
Exit Sub
End If
boo1 = (Me!ogDocumentRange <> Me!obSelected.OptionValue)
Me!txtCount.Visible = boo1
Me!txtTotal.Visible = boo1
Me!txtFileName.Visible = boo1
If Me!cbWatermark Then
' Get the watermark settings from system parameters
GetWatermark "DocExport", typWm
End If
If (Me!ogOutputFormat <> Me!obAsIs.OptionValue) _
Or (Me!cbEnclosures) _
Or (Me!cbReference) _
Or (Me!cbWatermark) Then
Set Word = GetWordObj
End If
' Populate Text File
If cbTxtFile Then
Handle = FreeFile
str1 = "ExportFile"
For int1 = 0 To rsWork.Fields.count - 1
If rsWork.Fields(int1).Type <> dbMemo Then
str1 = str1 & "," & rsWork.Fields(int1).Name
End If
Next int1
If ogOutputFileNames = 4 Then
Open Left(Me!txtPath, FindLast(Me!txtPath, "\")) & "Export.TXT" For
Output Access Write As #Handle
Else
Open Me!txtPath & "\Export.TXT" For Output Access Write As #Handle
End If
Print #Handle, str1
End If
' Select Case Me!ogOutputFormat
' Case Me!obAdobePDF.OptionValue
' ' See if we can find the PDF Writer
' strTask = "Initializing Acrobat PdfWriter"
' SysCmd acSysCmdSetStatus, "Initializing Acrobat PdfWriter..."
' DoEvents
' GetPDFWriterInfo strPdfPrinter, strPdfPort
'
' If strPdfPrinter = "" Then
' Beep
' MsgBox "Unable to initialize Acrobat PdfWriter.", vbCritical,
MsgBoxTitle(cFuncName)
' GoTo ProcExit
' End If
'
' strPdfDevice = Space$(255)
' wu_GetProfileString "Devices", strPdfPrinter, "PDFWRITR,LPT1:",
strPdfDevice, 255
'
' GetPdfWriterSettings strSavePdfDocInfo, strSavePdfFileName
'
' str1 = strPdfPrinter & " on " & strPdfPort
' strSaveWordPrinter = Word.ActivePrinter
' If strSaveWordPrinter <> str1 Then Word.ActivePrinter = str1
' Case Me!obAdobePS.OptionValue
' ' See if we can find the Acrobat Distiller
' strTask = "Initializing Acrobat Distiller"
' SysCmd acSysCmdSetStatus, "Initializing Acrobat Distiller..."
' DoEvents
' strDistillerObject = GetRegistryString(adhcHKEY_CLASSES_ROOT,
"PdfDistiller.PdfDistiller\CurVer", "")
' strTask = "Initializing Acrobat Distiller (" & strDistillerObject & ")"
' Set objDistiller = CreateObject(strDistillerObject)
' GetPdfDistillerInfo strPdfPrinter, strPdfPort
'
' If strPdfPrinter = "" Then
' Beep
' MsgBox "Unable to initialize Acrobat Distiller.", vbCritical,
MsgBoxTitle(cFuncName)
' GoTo ProcExit
' End If
'
' strTask = "Saving Default Printer"
' strPdfDevice = Space$(255)
' wu_GetProfileString "Devices", strPdfPrinter, "", strPdfDevice, 255
'
' str1 = strPdfPrinter & " on " & strPdfPort
' strSaveWordPrinter = Word.ActivePrinter
' If strSaveWordPrinter <> str1 Then Word.ActivePrinter = str1
'
' ' Save off the current Distiller security settings
' strTask = "Saving Distiller Settings"
' GetDistillerSecuritySettings typSaveDS
'
' ' Get the IRMS settings for Distilling
' strTask = "Reading IRMS Distiller Settings"
' GetIrmsDistillerSecurity "DocExport", typDS, rsWork!Division
'
' ' Change the Distiller security settings to the DocExport settings
' strTask = "Setting Distiller to IRMS Settings"
' If Not WriteDistillerSecuritySettings(typSaveDS, typDS) Then
' Beep
' If MsgBox("IRMS is unable to modify the Acrobat Distiller security
settings." _
' & vbCrLf & vbCrLf & "Do you want to continue using the settings
as they are?", _
' vbQuestion + vbYesNo) <> vbYes Then
' GoTo ProcExit
' End If
' Else
' booAltereredDistiller = True
' End If
'
' End Select
strTask = "Processing Documents"
SysCmd acSysCmdSetStatus, "Processing Documents..."
DoEvents
Select Case Me!ogDocumentRange
Case Me!obAll.OptionValue
rsWork.MoveLast
lngTotal = rsWork.RecordCount
rsWork.MoveFirst
DoEvents
Case Else
Select Case Me.OpenArgs
Case "DocControl"
rsWork.bookmark = Forms!DocCOntrol.bookmark
lngTotal = 1
Case "DocSearch"
Select Case Me!ogDocumentRange
Case Me!obChecked.OptionValue
rsWork.MoveFirst
Do Until rsWork!Selected
rsWork.MoveNext
If rsWork.EOF Then
Beep
MsgBox "No documents were checked!" & vbCrLf & vbCrLf _
& "Please indicate your selection by checking one or more
documents " _
& "and try again.", _
vbCritical, MsgBoxTitle("Document Export")
GoTo ProcExit
End If
Loop
rsWork.MoveLast
lngTotal = rsWork.RecordCount
rsWork.MoveFirst
Case Else
rsWork.bookmark = Forms!DocSearch!Docs.Form.bookmark
lngTotal = 1
End Select
End Select
End Select
Me!txtTotal = lngTotal
Do Until rsWork.EOF
' increment the status display
lngCount = lngCount + 1
Me!txtCount = lngCount
DoEvents
Select Case Me.OpenArgs
Case "DocControl"
booDoThisOne = True
Case "DocSearch"
booDoThisOne = rsWork!Selected Or (Me!ogDocumentRange <>
Me!obChecked.OptionValue)
End Select
If booDoThisOne Then
If Me!ogOutputFileNames <> Me!obFileName.OptionValue Then
' Build the file name according to the option specified
Select Case Me!ogOutputFileNames
Case Me!obControlN
ptionValue
' strOutFile = Format(rsWork!RefNo, gszDirFormat)
strOutFile = Format(rsWork!RefNo, "00000000")
Case Me!obDocumentID.OptionValue
var1 = rsWork!Code
If IsNull(var1) Then
str1 = "unk" & rsWork!RefNo
Else
str1 = var1
End If
strOutFile = LegalizeFilename(str1, " ")
Case Me!obTitle.OptionValue
var1 = rsWork!Title
If IsNull(var1) Then
str1 = "Untitled_" & rsWork!RefNo
Else
str1 = var1
End If
strOutFile = LegalizeFilename(str1, " ")
End Select
' strPSFile = FileName(Me!txtPath, strOutFile & ".PS")
' strLogFile = FileName(Me!txtPath, strOutFile & ".LOG")
strOutFile = strOutFile & "." & Me!cbExtension
strOutFile = FileName(Me!txtPath, strOutFile)
Else
strOutFile = Me!txtPath
int1 = FindLast(strOutFile, ".")
str1 = Left(strOutFile, int1 - 1)
' strPSFile = str1 & ".PS"
' strLogFile = str1 & ".LOG"
End If
' Let the user know what file we're working on
Me!txtFileName = strOutFile
DoEvents
' Do the export for this Document Control record
If Nz(rsWork!HasLink, False) Then
' Just copy it for now
int1 = ContentsToFile(Forms!DocumentExport, rsWork, strOutFile, "",
True)
Else
If (Me!ogOutputFormat = Me!obAsIs.OptionValue) _
And Not (Me!cbEnclosures Or Me!cbReference Or Me!cbWatermark) Then
' Copy the file as is
int1 = ContentsToFile(Forms!DocumentExport, rsWork, strOutFile,
"", True)
Else
strDocFile = FileName(gszIrmsDirectory & "\DOCS",
Format(rsWork!RefNo, gszDirFormat) & ".DOC")
strDocFileShort = Mid(strDocFile, FindLast(strDocFile, "\") + 1)
If Dir(strDocFile) <> "" Then
' Open up the document in word
Word.Documents.Open strDocFile, 0, -1, 0
'***> 4.3.19.0 (04/04/2001) - whn - Allow use of enclosures and
references in Pdf Exports
'Select Case Me!ogOutputFormat
'Case Me!obAsIs.OptionValue
If Me!cbEnclosures Then
' Build and Insert the enclosures
var1 = BuildEnclosures("Document", rsWork!RefNo)
If var1 <> "" Then
With Word.Documents(strDocFileShort).ActiveWindow.Selection
.EndKey Unit:=6
.TypeParagraph
.TypeParagraph
.TypeText Text:="Enclosures:"
.TypeParagraph
End With
End If
Do While var1 <> ""
Word.Documents(strDocFileShort).ActiveWindow.Selection.TypeText
Text:=Left(var1, 240)
var1 = Mid(var1, 241)
Loop
End If
If Me!cbReference Then
' Find and Insert the reference document
var1 = FindDocument("Document", Null, "Reference",
rsWork!Language, rsWork!Status, rsWork!Code, rsWork!Dept, rsWork!Division)
str1 = FileName(gszIrmsDirectory & "\DOCS", Format$(var1,
gszDirFormat) & ".DOC")
If Dir(str1) <> "" Then
Word.Documents(strDocFileShort).ActiveWindow.Selection.EndKey Unit:=6
Word.Documents(strDocFileShort).ActiveWindow.Selection.TypeParagraph
Word.Documents(strDocFileShort).ActiveWindow.Selection.paragraphformat.LeftIndent = 0
Word.Documents(strDocFileShort).ActiveWindow.Selection.TypeParagraph
Word.Documents(strDocFileShort).ActiveWindow.Selection.InsertFile
FileName:=str1, Range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False
DoEvents
End If
End If
Select Case Me!ogOutputFormat
Case Me!obAsIs.OptionValue
' Save the file to the output file name
If Me!cbWatermark Then
ApplyWatermark Word, typWm
DoEvents
End If
Word.Documents(strDocFileShort).SaveAs FileName:=strOutFile, _
LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:=True
Word.Documents(Mid(strOutFile, FindLast(strOutFile, "\") +
1)).Close SaveChanges:=False
Case Me!obAdobePDF.OptionValue
' Make sure everything is set for PDFWriter
MakeFolderForFile strOutFile
' WritePDFWriterKeyValue "PDFFileName", strOutFile
' DoEvents
If Me!cbWatermark Then
ApplyWatermark Word, typWm
DoEvents
End If
WritePDFFile Word, strOutFile, False, rsWork!Division,
"DocExport", strDocFile
Word.Documents(strDocFileShort).PrintRevisions = 0
' Word.Documents(strDocFileShort).PrintOut Item:=0,
Background:=False
Word.Documents(strDocFileShort).Close SaveChanges:=False
Case Me!obAdobePS.OptionValue
' Print to the Distiller (postscript file) printer
' MakeFolderForFile strPSFile
If Me!cbWatermark Then
ApplyWatermark Word, typWm
DoEvents
End If
WritePDFFile Word, strOutFile, True, rsWork!Division,
"DocExport", strDocFile
Word.Documents(strDocFileShort).PrintRevisions = 0
' Word.Documents(strDocFileShort).PrintOut Item:=0, Copies:=1,
Pages:="", _
' Collate:=True, Background:=False, PrintToFile:=True, _
' OutputFileName:=strPSFile, Append:=False
Word.Documents(strDocFileShort).Close False
' ' Distill the postscript file into a PDF
' objDistiller.FileToPDF strPSFile, strOutFile, ""
' DoEvents
' On Error Resume Next
' Kill strPSFile
' On Error Resume Next
' Kill strLogFile
' On Error GoTo ProcError
End Select
End If
End If
End If
' Populate Text File
If cbTxtFile Then
str1 = """" & Mid(strOutFile, FindLast(strOutFile, "\") + 1) & """"
For int1 = 0 To rsWork.Fields.count - 1
If rsWork.Fields(int1).Type <> dbMemo Then
str1 = str1 & "," & """" & rsWork.Fields(int1) & """"
End If
Next int1
Print #Handle, str1
End If
End If
' Determine if we have more to do
DoEvents
If Me!ogDocumentRange = Me!obSelected.OptionValue Then Exit Do
rsWork.MoveNext
Loop
Me!txtFileName = ""
' Populate Text File
If cbTxtFile Then
Close Handle
End If
booSuccess = True
ProcExit:
' strTask = "Cleaning Up"
' If (Me!ogOutputFormat = Me!obAdobePDF.OptionValue) _
' Or (Me!ogOutputFormat = Me!obAdobePS.OptionValue) Then
' SysCmd acSysCmdSetStatus, "Resetting Default Printer..."
' str1 = strPdfPrinter & "," & FixCString(strPdfDevice)
' If strSaveWordPrinter <> str1 Then Word.ActivePrinter =
strSaveWordPrinter
' DoEvents
'
' '***> 4.3.19.0 (04/04/2001) - whn - Don't write PdfWriter Settings if
we used Distiller
' Select Case Me!ogOutputFormat
' Case Me!obAdobePDF.OptionValue
' ' Reset their PdfWriter Settings
' SysCmd acSysCmdSetStatus, "Resetting PdfWriter Settings..."
' If strSavePdfDocInfo <> "0" Then
' WritePDFWriterKeyValue "bDocInfo", strSavePdfDocInfo
' End If
' WritePDFWriterKeyValue "PDFFileName", strSavePdfFileName
' Case Me!obAdobePS.OptionValue
' ' Restore any distiller security settings that didn't match IRMS's
' If booAltereredDistiller Then
' If Not WriteDistillerSecuritySettings(typDS, typSaveDS) Then
' Beep
' MsgBox "IRMS is unable to restore the Acrobat Distiller security
settings." _
' & "You will have to go to Acrobat Distiller and do it
manually.", vbInformation
' End If
' End If
' End Select
' End If
DoEvents
' Set objDistiller = Nothing
On Error Resume Next
DoCmd.Hourglass False
Me!btnCancel.Caption = "Close"
SysCmd acSysCmdClearStatus
' Skip message box if there was an error
If booSuccess Then
Beep
MsgBox "EXPORT Complete", vbInformation + vbOKOnly,
MsgBoxTitle("Document Export")
End If
'Reset the status fields
Me!txtCount = ""
Me!txtTotal = ""
Me!txtCount.Visible = False
Me!txtTotal.Visible = False
Me!txtFileName.Visible = False
DoEvents
Exit Sub
ProcError:
' Select Case Err.Number
' Case 459
' Beep
' str1 = "IRMS can not start the Adobe Distiller. " _
' & "Please make sure the necessary files have been loaded " _
' & "and registered on your system."
' MsgBox str1, vbCritical + vbOKOnly, MsgBoxTitle(cFuncName)
' Resume ProcExit
' Case Else
'
' var1 = "Adobe Interface: " & strPdfPrinter & vbCrLf & "Distiller
Object: " & strDistillerObject & vbCrLf _
' & "Word Processing: " & Word.Version & vbCrLf & "Default Printer: " &
strSaveWordPrinter
' Select Case cErrHandler(intLockCount, CurrentObjectName, cFuncName,
strTask, Err.Number, Err.Description, 0, var1)
Select Case cErrHandler(intLockCount, CurrentObjectName, cFuncName, strTask,
Err.Number, Err.Description, 0, "")
Case vbIgnore: Stop: Resume
Case vbOK: Resume Next
Case vbAbort: Resume ProcExit
Case Else: Resume
End Select
' End Select
End Sub
documents that are being exported from a program added to a new WinZip file.
Below is the script as/is. Can anyone direct me to how I can add what is
necessary to make this happen. If it is more than a generic line of code or
two, please assist me with the syntax... Thanks to anyone in advance that
may help. Not very familiar with Access just got pegged to be involved with
the process. The code below describes the exported docs and all of the
options involved in the export/
Private Sub btnRun_Click()
Const cFuncName = "DocumentExport_Run"
Dim boo1 As Boolean
Dim int1 As Integer
Dim intLockCount As Integer
Dim Handle As Integer
Dim lng1 As Long
Dim str1 As String
Dim var1 As Variant
Dim booAltereredDistiller As Boolean
Dim booDoThisOne As Boolean
Dim booSuccess As Boolean
Dim lngCount As Long
Dim lngTotal As Long
' Dim strDistillerSecurity As String
' Dim strDistillerObject As String
Dim strDocFile As String
Dim strDocFileShort As String
' Dim strFontName As String
' Dim strLogFile As String
Dim strOutFile As String
' Dim strPdfDevice As String
' Dim strPdfPort As String
' Dim strPdfPrinter As String
' Dim strPSFile As String
' Dim strSavePdfDocInfo As String
' Dim strSavePdfFileName As String
Dim strSavePrinter As String
Dim strSaveWordPrinter As String
'***> 4.3.20.0 (04/12/2001) - whn - Provide Task breakout in error handler
Dim strTask As String
' Dim typDS As obaDistillerSecurity
' Dim typSaveDS As obaDistillerSecurity
Dim typWm As obaWatermark
Dim dr As adh_tagDeviceRec
Dim rsWatermark As Recordset
Dim rsWork As Recordset
' Dim objDistiller As Object
Dim Word As Object
On Error GoTo ProcError
DoCmd.Hourglass True
Select Case Me!ogDocumentRange
Case Me!obSelected.OptionValue
' See if output file already exists
If Dir(Me!txtPath) <> "" Then
Beep
If MsgBox(Me!txtPath & " already exists." & vbCrLf & vbCrLf _
& "Do you want to overwrite it?", _
vbQuestion + vbYesNo + vbDefaultButton2, MsgBoxTitle("Document
Export")) <> vbYes Then
DoCmd.Hourglass False
Exit Sub
End If
End If
Case Else
' See if output path already has files in it
If Dir(FileName(Me!txtPath, "*.*")) <> "" Then
Beep
If MsgBox(Me!txtPath & " already contains some files. " _
& "This procedure will overwrite files of the same name." _
& vbCrLf & vbCrLf & "Do you want to continue?", _
vbQuestion + vbYesNo + vbDefaultButton2, MsgBoxTitle("Document
Export")) <> vbYes Then
DoCmd.Hourglass False
Exit Sub
End If
End If
End Select
Select Case Me.OpenArgs
Case "DocControl"
Set rsWork = Forms!DocCOntrol.RecordsetClone
Case "DocSearch"
Set rsWork = Forms!DocSearch!Docs.Form.RecordsetClone
End Select
If rsWork.BOF Then
Beep
MsgBox "Select at least one record before choosing EXPORT", vbCritical,
MsgBoxTitle(cFuncName)
DoCmd.Hourglass False
Exit Sub
End If
boo1 = (Me!ogDocumentRange <> Me!obSelected.OptionValue)
Me!txtCount.Visible = boo1
Me!txtTotal.Visible = boo1
Me!txtFileName.Visible = boo1
If Me!cbWatermark Then
' Get the watermark settings from system parameters
GetWatermark "DocExport", typWm
End If
If (Me!ogOutputFormat <> Me!obAsIs.OptionValue) _
Or (Me!cbEnclosures) _
Or (Me!cbReference) _
Or (Me!cbWatermark) Then
Set Word = GetWordObj
End If
' Populate Text File
If cbTxtFile Then
Handle = FreeFile
str1 = "ExportFile"
For int1 = 0 To rsWork.Fields.count - 1
If rsWork.Fields(int1).Type <> dbMemo Then
str1 = str1 & "," & rsWork.Fields(int1).Name
End If
Next int1
If ogOutputFileNames = 4 Then
Open Left(Me!txtPath, FindLast(Me!txtPath, "\")) & "Export.TXT" For
Output Access Write As #Handle
Else
Open Me!txtPath & "\Export.TXT" For Output Access Write As #Handle
End If
Print #Handle, str1
End If
' Select Case Me!ogOutputFormat
' Case Me!obAdobePDF.OptionValue
' ' See if we can find the PDF Writer
' strTask = "Initializing Acrobat PdfWriter"
' SysCmd acSysCmdSetStatus, "Initializing Acrobat PdfWriter..."
' DoEvents
' GetPDFWriterInfo strPdfPrinter, strPdfPort
'
' If strPdfPrinter = "" Then
' Beep
' MsgBox "Unable to initialize Acrobat PdfWriter.", vbCritical,
MsgBoxTitle(cFuncName)
' GoTo ProcExit
' End If
'
' strPdfDevice = Space$(255)
' wu_GetProfileString "Devices", strPdfPrinter, "PDFWRITR,LPT1:",
strPdfDevice, 255
'
' GetPdfWriterSettings strSavePdfDocInfo, strSavePdfFileName
'
' str1 = strPdfPrinter & " on " & strPdfPort
' strSaveWordPrinter = Word.ActivePrinter
' If strSaveWordPrinter <> str1 Then Word.ActivePrinter = str1
' Case Me!obAdobePS.OptionValue
' ' See if we can find the Acrobat Distiller
' strTask = "Initializing Acrobat Distiller"
' SysCmd acSysCmdSetStatus, "Initializing Acrobat Distiller..."
' DoEvents
' strDistillerObject = GetRegistryString(adhcHKEY_CLASSES_ROOT,
"PdfDistiller.PdfDistiller\CurVer", "")
' strTask = "Initializing Acrobat Distiller (" & strDistillerObject & ")"
' Set objDistiller = CreateObject(strDistillerObject)
' GetPdfDistillerInfo strPdfPrinter, strPdfPort
'
' If strPdfPrinter = "" Then
' Beep
' MsgBox "Unable to initialize Acrobat Distiller.", vbCritical,
MsgBoxTitle(cFuncName)
' GoTo ProcExit
' End If
'
' strTask = "Saving Default Printer"
' strPdfDevice = Space$(255)
' wu_GetProfileString "Devices", strPdfPrinter, "", strPdfDevice, 255
'
' str1 = strPdfPrinter & " on " & strPdfPort
' strSaveWordPrinter = Word.ActivePrinter
' If strSaveWordPrinter <> str1 Then Word.ActivePrinter = str1
'
' ' Save off the current Distiller security settings
' strTask = "Saving Distiller Settings"
' GetDistillerSecuritySettings typSaveDS
'
' ' Get the IRMS settings for Distilling
' strTask = "Reading IRMS Distiller Settings"
' GetIrmsDistillerSecurity "DocExport", typDS, rsWork!Division
'
' ' Change the Distiller security settings to the DocExport settings
' strTask = "Setting Distiller to IRMS Settings"
' If Not WriteDistillerSecuritySettings(typSaveDS, typDS) Then
' Beep
' If MsgBox("IRMS is unable to modify the Acrobat Distiller security
settings." _
' & vbCrLf & vbCrLf & "Do you want to continue using the settings
as they are?", _
' vbQuestion + vbYesNo) <> vbYes Then
' GoTo ProcExit
' End If
' Else
' booAltereredDistiller = True
' End If
'
' End Select
strTask = "Processing Documents"
SysCmd acSysCmdSetStatus, "Processing Documents..."
DoEvents
Select Case Me!ogDocumentRange
Case Me!obAll.OptionValue
rsWork.MoveLast
lngTotal = rsWork.RecordCount
rsWork.MoveFirst
DoEvents
Case Else
Select Case Me.OpenArgs
Case "DocControl"
rsWork.bookmark = Forms!DocCOntrol.bookmark
lngTotal = 1
Case "DocSearch"
Select Case Me!ogDocumentRange
Case Me!obChecked.OptionValue
rsWork.MoveFirst
Do Until rsWork!Selected
rsWork.MoveNext
If rsWork.EOF Then
Beep
MsgBox "No documents were checked!" & vbCrLf & vbCrLf _
& "Please indicate your selection by checking one or more
documents " _
& "and try again.", _
vbCritical, MsgBoxTitle("Document Export")
GoTo ProcExit
End If
Loop
rsWork.MoveLast
lngTotal = rsWork.RecordCount
rsWork.MoveFirst
Case Else
rsWork.bookmark = Forms!DocSearch!Docs.Form.bookmark
lngTotal = 1
End Select
End Select
End Select
Me!txtTotal = lngTotal
Do Until rsWork.EOF
' increment the status display
lngCount = lngCount + 1
Me!txtCount = lngCount
DoEvents
Select Case Me.OpenArgs
Case "DocControl"
booDoThisOne = True
Case "DocSearch"
booDoThisOne = rsWork!Selected Or (Me!ogDocumentRange <>
Me!obChecked.OptionValue)
End Select
If booDoThisOne Then
If Me!ogOutputFileNames <> Me!obFileName.OptionValue Then
' Build the file name according to the option specified
Select Case Me!ogOutputFileNames
Case Me!obControlN
ptionValue' strOutFile = Format(rsWork!RefNo, gszDirFormat)
strOutFile = Format(rsWork!RefNo, "00000000")
Case Me!obDocumentID.OptionValue
var1 = rsWork!Code
If IsNull(var1) Then
str1 = "unk" & rsWork!RefNo
Else
str1 = var1
End If
strOutFile = LegalizeFilename(str1, " ")
Case Me!obTitle.OptionValue
var1 = rsWork!Title
If IsNull(var1) Then
str1 = "Untitled_" & rsWork!RefNo
Else
str1 = var1
End If
strOutFile = LegalizeFilename(str1, " ")
End Select
' strPSFile = FileName(Me!txtPath, strOutFile & ".PS")
' strLogFile = FileName(Me!txtPath, strOutFile & ".LOG")
strOutFile = strOutFile & "." & Me!cbExtension
strOutFile = FileName(Me!txtPath, strOutFile)
Else
strOutFile = Me!txtPath
int1 = FindLast(strOutFile, ".")
str1 = Left(strOutFile, int1 - 1)
' strPSFile = str1 & ".PS"
' strLogFile = str1 & ".LOG"
End If
' Let the user know what file we're working on
Me!txtFileName = strOutFile
DoEvents
' Do the export for this Document Control record
If Nz(rsWork!HasLink, False) Then
' Just copy it for now
int1 = ContentsToFile(Forms!DocumentExport, rsWork, strOutFile, "",
True)
Else
If (Me!ogOutputFormat = Me!obAsIs.OptionValue) _
And Not (Me!cbEnclosures Or Me!cbReference Or Me!cbWatermark) Then
' Copy the file as is
int1 = ContentsToFile(Forms!DocumentExport, rsWork, strOutFile,
"", True)
Else
strDocFile = FileName(gszIrmsDirectory & "\DOCS",
Format(rsWork!RefNo, gszDirFormat) & ".DOC")
strDocFileShort = Mid(strDocFile, FindLast(strDocFile, "\") + 1)
If Dir(strDocFile) <> "" Then
' Open up the document in word
Word.Documents.Open strDocFile, 0, -1, 0
'***> 4.3.19.0 (04/04/2001) - whn - Allow use of enclosures and
references in Pdf Exports
'Select Case Me!ogOutputFormat
'Case Me!obAsIs.OptionValue
If Me!cbEnclosures Then
' Build and Insert the enclosures
var1 = BuildEnclosures("Document", rsWork!RefNo)
If var1 <> "" Then
With Word.Documents(strDocFileShort).ActiveWindow.Selection
.EndKey Unit:=6
.TypeParagraph
.TypeParagraph
.TypeText Text:="Enclosures:"
.TypeParagraph
End With
End If
Do While var1 <> ""
Word.Documents(strDocFileShort).ActiveWindow.Selection.TypeText
Text:=Left(var1, 240)
var1 = Mid(var1, 241)
Loop
End If
If Me!cbReference Then
' Find and Insert the reference document
var1 = FindDocument("Document", Null, "Reference",
rsWork!Language, rsWork!Status, rsWork!Code, rsWork!Dept, rsWork!Division)
str1 = FileName(gszIrmsDirectory & "\DOCS", Format$(var1,
gszDirFormat) & ".DOC")
If Dir(str1) <> "" Then
Word.Documents(strDocFileShort).ActiveWindow.Selection.EndKey Unit:=6
Word.Documents(strDocFileShort).ActiveWindow.Selection.TypeParagraph
Word.Documents(strDocFileShort).ActiveWindow.Selection.paragraphformat.LeftIndent = 0
Word.Documents(strDocFileShort).ActiveWindow.Selection.TypeParagraph
Word.Documents(strDocFileShort).ActiveWindow.Selection.InsertFile
FileName:=str1, Range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False
DoEvents
End If
End If
Select Case Me!ogOutputFormat
Case Me!obAsIs.OptionValue
' Save the file to the output file name
If Me!cbWatermark Then
ApplyWatermark Word, typWm
DoEvents
End If
Word.Documents(strDocFileShort).SaveAs FileName:=strOutFile, _
LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:=True
Word.Documents(Mid(strOutFile, FindLast(strOutFile, "\") +
1)).Close SaveChanges:=False
Case Me!obAdobePDF.OptionValue
' Make sure everything is set for PDFWriter
MakeFolderForFile strOutFile
' WritePDFWriterKeyValue "PDFFileName", strOutFile
' DoEvents
If Me!cbWatermark Then
ApplyWatermark Word, typWm
DoEvents
End If
WritePDFFile Word, strOutFile, False, rsWork!Division,
"DocExport", strDocFile
Word.Documents(strDocFileShort).PrintRevisions = 0
' Word.Documents(strDocFileShort).PrintOut Item:=0,
Background:=False
Word.Documents(strDocFileShort).Close SaveChanges:=False
Case Me!obAdobePS.OptionValue
' Print to the Distiller (postscript file) printer
' MakeFolderForFile strPSFile
If Me!cbWatermark Then
ApplyWatermark Word, typWm
DoEvents
End If
WritePDFFile Word, strOutFile, True, rsWork!Division,
"DocExport", strDocFile
Word.Documents(strDocFileShort).PrintRevisions = 0
' Word.Documents(strDocFileShort).PrintOut Item:=0, Copies:=1,
Pages:="", _
' Collate:=True, Background:=False, PrintToFile:=True, _
' OutputFileName:=strPSFile, Append:=False
Word.Documents(strDocFileShort).Close False
' ' Distill the postscript file into a PDF
' objDistiller.FileToPDF strPSFile, strOutFile, ""
' DoEvents
' On Error Resume Next
' Kill strPSFile
' On Error Resume Next
' Kill strLogFile
' On Error GoTo ProcError
End Select
End If
End If
End If
' Populate Text File
If cbTxtFile Then
str1 = """" & Mid(strOutFile, FindLast(strOutFile, "\") + 1) & """"
For int1 = 0 To rsWork.Fields.count - 1
If rsWork.Fields(int1).Type <> dbMemo Then
str1 = str1 & "," & """" & rsWork.Fields(int1) & """"
End If
Next int1
Print #Handle, str1
End If
End If
' Determine if we have more to do
DoEvents
If Me!ogDocumentRange = Me!obSelected.OptionValue Then Exit Do
rsWork.MoveNext
Loop
Me!txtFileName = ""
' Populate Text File
If cbTxtFile Then
Close Handle
End If
booSuccess = True
ProcExit:
' strTask = "Cleaning Up"
' If (Me!ogOutputFormat = Me!obAdobePDF.OptionValue) _
' Or (Me!ogOutputFormat = Me!obAdobePS.OptionValue) Then
' SysCmd acSysCmdSetStatus, "Resetting Default Printer..."
' str1 = strPdfPrinter & "," & FixCString(strPdfDevice)
' If strSaveWordPrinter <> str1 Then Word.ActivePrinter =
strSaveWordPrinter
' DoEvents
'
' '***> 4.3.19.0 (04/04/2001) - whn - Don't write PdfWriter Settings if
we used Distiller
' Select Case Me!ogOutputFormat
' Case Me!obAdobePDF.OptionValue
' ' Reset their PdfWriter Settings
' SysCmd acSysCmdSetStatus, "Resetting PdfWriter Settings..."
' If strSavePdfDocInfo <> "0" Then
' WritePDFWriterKeyValue "bDocInfo", strSavePdfDocInfo
' End If
' WritePDFWriterKeyValue "PDFFileName", strSavePdfFileName
' Case Me!obAdobePS.OptionValue
' ' Restore any distiller security settings that didn't match IRMS's
' If booAltereredDistiller Then
' If Not WriteDistillerSecuritySettings(typDS, typSaveDS) Then
' Beep
' MsgBox "IRMS is unable to restore the Acrobat Distiller security
settings." _
' & "You will have to go to Acrobat Distiller and do it
manually.", vbInformation
' End If
' End If
' End Select
' End If
DoEvents
' Set objDistiller = Nothing
On Error Resume Next
DoCmd.Hourglass False
Me!btnCancel.Caption = "Close"
SysCmd acSysCmdClearStatus
' Skip message box if there was an error
If booSuccess Then
Beep
MsgBox "EXPORT Complete", vbInformation + vbOKOnly,
MsgBoxTitle("Document Export")
End If
'Reset the status fields
Me!txtCount = ""
Me!txtTotal = ""
Me!txtCount.Visible = False
Me!txtTotal.Visible = False
Me!txtFileName.Visible = False
DoEvents
Exit Sub
ProcError:
' Select Case Err.Number
' Case 459
' Beep
' str1 = "IRMS can not start the Adobe Distiller. " _
' & "Please make sure the necessary files have been loaded " _
' & "and registered on your system."
' MsgBox str1, vbCritical + vbOKOnly, MsgBoxTitle(cFuncName)
' Resume ProcExit
' Case Else
'
' var1 = "Adobe Interface: " & strPdfPrinter & vbCrLf & "Distiller
Object: " & strDistillerObject & vbCrLf _
' & "Word Processing: " & Word.Version & vbCrLf & "Default Printer: " &
strSaveWordPrinter
' Select Case cErrHandler(intLockCount, CurrentObjectName, cFuncName,
strTask, Err.Number, Err.Description, 0, var1)
Select Case cErrHandler(intLockCount, CurrentObjectName, cFuncName, strTask,
Err.Number, Err.Description, 0, "")
Case vbIgnore: Stop: Resume
Case vbOK: Resume Next
Case vbAbort: Resume ProcExit
Case Else: Resume
End Select
' End Select
End Sub