Attribute VB_Name = "modActiveReport"
Option Explicit
Public gstrExportButton As String
Public gstrExportToolTip As String
Public gstrExportFormat As String
Public gblnPreviewStatus As Boolean
Public Sub ExportReport(tmpActiveReport As ActiveReport, Optional tmpAllowFilter As String = "110000")
On Error GoTo EH
Dim intX As Integer
Dim tmpFilter As String
Dim pblnPDF As Boolean
Dim pblnXLS As Boolean
Dim pblnTXT As Boolean
Dim pblnHTML As Boolean
Dim pblnTIFF As Boolean
Dim pblnRTF As Boolean
Dim PDF As ActiveReportsPDFExport.ARExportPDF
Dim XLS As ActiveReportsExcelExport.ARExportExcel
Dim RTF As ActiveReportsRTFExport.ARExportRTF
Dim TXT As ActiveReportsTextExport.ARExportText
Dim TIFF As ActiveReportsTIFFExport.TIFFExport
Dim HTML As ActiveReportsHTMLExport.HTMLexport
Dim ExportForm As frmExport
Dim iFirstPeriod As Integer
For intX = 1 To Len(tmpAllowFilter)
Select Case intX
Case 1
pblnPDF = cuBool(Mid(tmpAllowFilter, intX, 1))
If pblnPDF = True Then tmpFilter = "Adobe Acrobat Format (*.pdf)|*.pdf"
Case 2
pblnXLS = cuBool(Mid(tmpAllowFilter, intX, 1))
If pblnXLS = True Then
If Len(tmpFilter) > 0 Then tmpFilter = tmpFilter & "|"
tmpFilter = tmpFilter & "Excel Format (*.xls)|*.xls"
End If
Case 3
pblnTXT = cuBool(Mid(tmpAllowFilter, intX, 1))
If pblnTXT = True Then
If Len(tmpFilter) > 0 Then tmpFilter = tmpFilter & "|"
tmpFilter = tmpFilter & "Text Format (*.txt)|*.txt"
End If
Case 4
pblnTIFF = cuBool(Mid(tmpAllowFilter, intX, 1))
If pblnTIFF = True Then
If Len(tmpFilter) > 0 Then tmpFilter = tmpFilter & "|"
tmpFilter = tmpFilter & "Tiff Format (*.tif)|*.tif"
End If
Case 5
pblnHTML = cuBool(Mid(tmpAllowFilter, intX, 1))
If pblnHTML = True Then
If Len(tmpFilter) > 0 Then tmpFilter = tmpFilter & "|"
tmpFilter = tmpFilter & "Html Format (*.htm)|*.htm"
End If
Case 6
pblnRTF = cuBool(Mid(tmpAllowFilter, intX, 1))
If pblnRTF = True Then
If Len(tmpFilter) > 0 Then tmpFilter = tmpFilter & "|"
tmpFilter = tmpFilter & "Rich Text Format (*.rtf)|*.rtf"
End If
End Select
Next
If pblnPDF Or pblnXLS Or pblnTXT Or pblnTIFF Or pblnHTML Or pblnRTF = True Then
Set ExportForm = New frmExport
ExportForm.dlgCommon.filename = "Export"
ExportForm.dlgCommon.Filter = tmpFilter
ExportForm.dlgCommon.CancelError = True
ExportForm.dlgCommon.flags = cdlOFNHideReadOnly + cdlOFNLongNames + cdlOFNPathMustExist
On Error Resume Next
ExportForm.dlgCommon.ShowSave
'If user Cancelled, then error 32755 will be raised
If Err Then
Err.Clear
Exit Sub
End If
On Error GoTo EH
'If ther are two periods(.) in the filename, then display an error
'2010-3-29 取消檢查檔案名稱, 避免資料夾有 FullStop 出現錯誤
' iFirstPeriod = InStr(ExportForm.dlgCommon.filename, ".")
' If InStr(Mid(ExportForm.dlgCommon.filename, iFirstPeriod + 1), ".") > 0 Then
' Beep
' MsgBox "Invalid File Name", vbOKOnly, "Export Report Message"
' Exit Sub
' End If
Select Case True
Case UCase(Right$(Trim$(ExportForm.dlgCommon.filename), 4)) = ".PDF"
If pblnPDF = True Then
Set PDF = New ActiveReportsPDFExport.ARExportPDF
PDF.filename = ExportForm.dlgCommon.filename
tmpActiveReport.Export PDF
Beep
MsgBox "Your report has been saved to " & ExportForm.dlgCommon.filename, vbOKOnly, "Export Report Message"
End If
Case UCase(Right$(Trim$(ExportForm.dlgCommon.filename), 4)) = ".XLS"
If pblnXLS = True Then
Set XLS = New ActiveReportsExcelExport.ARExportExcel
XLS.filename = ExportForm.dlgCommon.filename
tmpActiveReport.Export XLS
Beep
MsgBox "Your report has been saved to " & ExportForm.dlgCommon.filename, vbOKOnly, "Export Report Message"
End If
Case UCase(Right$(Trim$(ExportForm.dlgCommon.filename), 4)) = ".TXT"
If pblnTXT = True Then
Set TXT = New ActiveReportsTextExport.ARExportText
TXT.filename = ExportForm.dlgCommon.filename
tmpActiveReport.Export TXT
Beep
MsgBox "Your report has been saved to " & ExportForm.dlgCommon.filename, vbOKOnly, "Export Report Message"
End If
Case UCase(Right$(Trim$(ExportForm.dlgCommon.filename), 4)) = ".TIF"
If pblnTIFF = True Then
Set TIFF = New ActiveReportsTIFFExport.TIFFExport
TIFF.filename = ExportForm.dlgCommon.filename
tmpActiveReport.Export TIFF
Beep
MsgBox "Your report has been saved to " & ExportForm.dlgCommon.filename, vbOKOnly, "Export Report Message"
End If
Case UCase(Right$(Trim$(ExportForm.dlgCommon.filename), 4)) = ".HTM"
If pblnHTML = True Then
Set HTML = New ActiveReportsHTMLExport.HTMLexport
HTML.filename = ExportForm.dlgCommon.filename
tmpActiveReport.Export HTML
Beep
MsgBox "Your report has been saved to " & ExportForm.dlgCommon.filename, vbOKOnly, "Export Report Message"
End If
Case UCase(Right$(Trim$(ExportForm.dlgCommon.filename), 4)) = ".RTF"
If pblnRTF = True Then
Set RTF = New ActiveReportsRTFExport.ARExportRTF
RTF.filename = ExportForm.dlgCommon.filename
tmpActiveReport.Export RTF
Beep
MsgBox "Your report has been saved to " & ExportForm.dlgCommon.filename, vbOKOnly, "Export Report Message"
End If
Case Else
Beep
MsgBox "Invalid File Name", vbOKOnly, "Export Report Message"
Exit Sub
End Select
End If
Set PDF = Nothing
Set RTF = Nothing
Set TXT = Nothing
Set XLS = Nothing
Set TIFF = Nothing
Set HTML = Nothing
Set ExportForm = Nothing
Exit Sub
EH:
Set PDF = Nothing
Set RTF = Nothing
Set TXT = Nothing
Set XLS = Nothing
Set HTML = Nothing
Set TIFF = Nothing
Set ExportForm = Nothing
Screen.MousePointer = vbDefault
Beep
MsgBox Err.Description, vbOKOnly, "Error Message"
End Sub
Public Sub LoadDefaultRptFormat(tmpReport As ActiveReport)
Dim intX As Integer
Dim sct As Section
Dim fnt As Object
For Each sct In tmpReport.Sections
For intX = 0 To sct.Controls.Count - 1
Select Case LCase(TypeName(sct.Controls(intX)))
Case "label"
Set fnt = sct.Controls(intX).font
fnt.name = DefRptLabel.FontName
fnt.Size = DefRptLabel.FontSize
fnt.Bold = DefRptLabel.FontBold
fnt.Italic = DefRptLabel.FontItalic
fnt.Underline = DefRptLabel.FontUnderline
fnt.Strikethrough = DefRptLabel.FontStrikethrough
Case "field"
Set fnt = sct.Controls(intX).font
fnt.name = DefRptField.FontName
fnt.Size = DefRptField.FontSize
fnt.Bold = DefRptField.FontBold
fnt.Italic = DefRptField.FontItalic
fnt.Underline = DefRptField.FontUnderline
fnt.Strikethrough = DefRptField.FontStrikethrough
End Select
Next intX
Next sct
End Sub
Public Function GetFieldOutputFormat(Optional tmpDecimal As Integer = 2) As String
Dim intX As Integer
Dim tmpResult As String
tmpResult = "#,##0"
If tmpDecimal > 0 Then
tmpResult = tmpResult & ".0"
If tmpDecimal > 1 Then
For intX = 2 To tmpDecimal
tmpResult = tmpResult & "#"
Next
End If
End If
GetFieldOutputFormat = tmpResult
End Function
Public Sub FormatRptField(tmpobj As Object, Optional tmpFontStr As String)
Dim fnt As Object
Dim intX As Integer
Dim FinalFontStr As String
Dim SepFontStr() As String
Dim tmpProperties As String
Dim tmpValue As String
Dim startParam As Boolean
If Len(tmpFontStr) > 0 Then
startParam = False
For intX = 0 To UBound(garyRptSetting, 1)
If garyRptSetting(intX, 0) = tmpFontStr Then
FinalFontStr = garyRptSetting(intX, 1)
Exit For
End If
Next
For intX = 1 To Len(FinalFontStr)
If Mid(FinalFontStr, intX, 1) <> strSeperateChar Then
If Mid(FinalFontStr, intX, 1) <> ":" Then
If startParam = False Then
tmpProperties = tmpProperties & Mid(FinalFontStr, intX, 1)
Else
tmpValue = tmpValue & Mid(FinalFontStr, intX, 1)
End If
Else
startParam = True
End If
Else
Set fnt = tmpobj.font
Select Case tmpProperties
Case "fontname"
fnt.name = tmpValue
Case "fontsize"
fnt.Size = Val(tmpValue)
Case "fontbold"
fnt.Bold = CBool(tmpValue)
Case "fontitalic"
fnt.Italic = CBool(tmpValue)
Case "fontunderline"
fnt.Underline = CBool(tmpValue)
Case "fontstrikethrough"
fnt.Strikethrough = CBool(tmpValue)
End Select
startParam = False
tmpProperties = ""
tmpValue = ""
End If
Next
Else
Set fnt = tmpobj.font
fnt.name = DefRptField.FontName
fnt.Size = DefRptField.FontSize
fnt.Bold = DefRptField.FontBold
fnt.Italic = DefRptField.FontItalic
fnt.Underline = DefRptField.FontUnderline
fnt.Strikethrough = DefRptField.FontStrikethrough
End If
Set fnt = Nothing
End Sub
Public Sub FormatRptLabel(tmpobj As Object, Optional tmpFontStr As String)
Dim fnt As Object
Dim intX As Integer
Dim FinalFontStr As String
Dim SepFontStr() As String
Dim tmpProperties As String
Dim tmpValue As String
Dim startParam As Boolean
If strSeperateChar = Empty Then strSeperateChar = ";"
If Len(tmpFontStr) > 0 Then
startParam = False
For intX = 0 To UBound(garyRptSetting, 1)
If garyRptSetting(intX, 0) = tmpFontStr Then
FinalFontStr = garyRptSetting(intX, 1)
Exit For
End If
Next
For intX = 1 To Len(FinalFontStr)
If Mid(FinalFontStr, intX, 1) <> strSeperateChar Then
If Mid(FinalFontStr, intX, 1) <> ":" Then
If startParam = False Then
tmpProperties = tmpProperties & Mid(FinalFontStr, intX, 1)
Else
tmpValue = tmpValue & Mid(FinalFontStr, intX, 1)
End If
Else
startParam = True
End If
Else
Set fnt = tmpobj.font
Select Case LCase(tmpProperties)
Case "fontname"
fnt.name = tmpValue
Case "fontsize"
fnt.Size = Val(tmpValue)
Case "fontbold"
fnt.Bold = CBool(tmpValue)
Case "fontitalic"
fnt.Italic = CBool(tmpValue)
Case "fontunderline"
fnt.Underline = CBool(tmpValue)
Case "fontstrikethrough"
fnt.Strikethrough = CBool(tmpValue)
End Select
startParam = False
tmpProperties = ""
tmpValue = ""
End If
Next
Else
Set fnt = tmpobj.font
fnt.name = DefRptLabel.FontName
If Len(tmpobj.Caption) > 12 Then
If tmpobj.width <= 1200 Then
fnt.Size = DefRptLabel.FontSize - 1
Else
fnt.Size = DefRptLabel.FontSize
End If
Else
fnt.Size = DefRptLabel.FontSize
End If
fnt.Bold = DefRptLabel.FontBold
fnt.Italic = DefRptLabel.FontItalic
fnt.Underline = DefRptLabel.FontUnderline
fnt.Strikethrough = DefRptLabel.FontStrikethrough
End If
Set fnt = Nothing
End Sub
Public Sub cuFormatRptField(tmpobj As Object, tmpArray() As String, Optional tmpFontStr As String)
Dim fnt As Object
Dim intX As Integer
Dim FinalFontStr As String
Dim SepFontStr() As String
Dim tmpProperties As String
Dim tmpValue As String
Dim startParam As Boolean
If Len(tmpFontStr) > 0 Then
startParam = False
For intX = 0 To UBound(tmpArray, 1)
If LCase(tmpArray(intX, 0)) = LCase(tmpFontStr) Then
FinalFontStr = tmpArray(intX, 1)
Exit For
End If
Next
For intX = 1 To Len(FinalFontStr)
If Mid(FinalFontStr, intX, 1) <> strSeperateChar Then
If Mid(FinalFontStr, intX, 1) <> ":" Then
If startParam = False Then
tmpProperties = tmpProperties & Mid(FinalFontStr, intX, 1)
Else
tmpValue = tmpValue & Mid(FinalFontStr, intX, 1)
End If
Else
startParam = True
End If
Else
Set fnt = tmpobj.font
Select Case tmpProperties
Case "fontname"
fnt.name = tmpValue
Case "fontsize"
fnt.Size = Val(tmpValue)
Case "fontbold"
fnt.Bold = CBool(tmpValue)
Case "fontitalic"
fnt.Italic = CBool(tmpValue)
Case "fontunderline"
fnt.Underline = CBool(tmpValue)
Case "fontstrikethrough"
fnt.Strikethrough = CBool(tmpValue)
End Select
startParam = False
tmpProperties = ""
tmpValue = ""
End If
Next
Else
Set fnt = tmpobj.font
fnt.name = DefRptField.FontName
fnt.Size = DefRptField.FontSize
fnt.Bold = DefRptField.FontBold
fnt.Italic = DefRptField.FontItalic
fnt.Underline = DefRptField.FontUnderline
fnt.Strikethrough = DefRptField.FontStrikethrough
End If
Set fnt = Nothing
End Sub
Public Sub cuFormatRptLabel(tmpobj As Object, tmpArray() As String, Optional tmpFontStr As String)
Dim fnt As Object
Dim intX As Integer
Dim FinalFontStr As String
Dim SepFontStr() As String
Dim tmpProperties As String
Dim tmpValue As String
Dim startParam As Boolean
If Len(tmpFontStr) > 0 Then
startParam = False
For intX = 0 To UBound(tmpArray, 1)
If LCase(tmpArray(intX, 0)) = LCase(tmpFontStr) Then
FinalFontStr = tmpArray(intX, 1)
Exit For
End If
Next
For intX = 1 To Len(FinalFontStr)
If Mid(FinalFontStr, intX, 1) <> strSeperateChar Then
If Mid(FinalFontStr, intX, 1) <> ":" Then
If startParam = False Then
tmpProperties = tmpProperties & Mid(FinalFontStr, intX, 1)
Else
tmpValue = tmpValue & Mid(FinalFontStr, intX, 1)
End If
Else
startParam = True
End If
Else
Set fnt = tmpobj.font
Select Case tmpProperties
Case "fontname"
fnt.name = tmpValue
Case "fontsize"
fnt.Size = Val(tmpValue)
Case "fontbold"
fnt.Bold = CBool(tmpValue)
Case "fontitalic"
fnt.Italic = CBool(tmpValue)
Case "fontunderline"
fnt.Underline = CBool(tmpValue)
Case "fontstrikethrough"
fnt.Strikethrough = CBool(tmpValue)
End Select
startParam = False
tmpProperties = ""
tmpValue = ""
End If
Next
Else
Set fnt = tmpobj.font
fnt.name = DefRptLabel.FontName
fnt.Size = DefRptLabel.FontSize
fnt.Bold = DefRptLabel.FontBold
fnt.Italic = DefRptLabel.FontItalic
fnt.Underline = DefRptLabel.FontUnderline
fnt.Strikethrough = DefRptLabel.FontStrikethrough
End If
Set fnt = Nothing
End Sub
