formatsetclass.cls

金算盘软件代码

    End With
    
    '取字体表属性
    strTemp = " lngFontID IN (" & mlngFontID(0) & "," & mlngFontID(1) & "," & mlngFontID(2) & "," & mlngFontID(3) & "," & mlngFontID(4) & ")"
    For intCount = 0 To 4
        colFontID.Add intCount, CStr(mlngFontID(intCount))
    Next intCount
    strSQL = "SELECT * FROM Font WHERE " & strTemp
    Set rstInit = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    With rstInit
        Do Until .EOF
            intLoc = -1
            intLoc = colFontID.Item(CStr(!lngFontID))
            If intLoc > -1 Then
                mfntPropertiy(intLoc).Name = !strFontName
                mfntPropertiy(intLoc).Size = !dblSize
                mfntPropertiy(intLoc).Charset = !intCharSet
                mfntPropertiy(intLoc).Bold = !blnIsBold
                mfntPropertiy(intLoc).Italic = !blnIsItalic
                mfntPropertiy(intLoc).Strikethrough = !blnIsStrikeThrough
                mfntPropertiy(intLoc).UnderLine = !blnISUnderLine
            End If
            .MoveNext
        Loop
    End With
    Set rstInit = Nothing
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                  私有过程
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'替换宏
Private Function ReplaceString(ByVal strOld As String) As String
Dim strName As String
    strName = strOld
    strName = strReplace(strName, "&[日期]", Format(Date, "YYYY-MM-DD"))
    strName = strReplace(strName, "&[时间]", Time)
    strName = strReplace(strName, "&[用户名]", gclsBase.OperatorName)
    strName = strReplace(strName, "&[单位名]", gclsBase.BaseName)
    ReplaceString = strName
End Function
'只提交纸张
Private Sub SavePaper()
Dim strSQL As String
Dim rstFind  As rdoResultset
Dim intCount  As Integer
    If mintPaperTypeIndex1 = 0 Then '如果是默认纸张时,直接改变其打印对象的纵横属性
        Printer.Orientation = IIf(mblnPortrait, 1, 2)
    End If
    '再找一次打印设置是否为预置
    If mblnPreSet Then
        strSQL = "SELECT lngPrintSetupID FROM Report WHERE lngReportID=" & mlngReportID
        Set rstFind = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
        If rstFind!lngPrintSetupID = 0 Then
            '复制打印设置记录
            mlngPrintSetupID = GetPrintSetupID
            mblnPreSet = False
        End If
    End If
    '提交打印设置表
    strSQL = " lngPaperSize=" & mintPaperTypeIndex1 & ",intPaperSizeIndex=" & mintPaperIndex _
        & ",lngPaperWidth=" & mlngPaperWidth & ",lngPaperLength=" & mlngPaperHeight _
        & ",lngOrientation=" & IIf(mblnPortrait, 1, 2)
    strSQL = "UPDATE PrintSetup SET " & strSQL & " WHERE lngPrintSetupID=" & mlngPrintSetupID
    gclsBase.ExecSQL strSQL
    Set rstFind = Nothing
End Sub

Private Sub SaveToDateBase()
Dim strSQL As String
Dim rstFind  As rdoResultset
Dim intCount  As Integer
    
    If mlngSeriesPrintID > 0 Then      '套打
        '提交数字显示设置与边距
        strSQL = "UPDATE PrintSetup SET blnIsCashLine=" & IIf(mblnShowMoneyLine, 1, 0) & ",blnIsShowZero=" & IIf(mblnShowNotZero, 1, 0) & ",blnIsShowSeprate=" & IIf(mblnShowSeprate, 1, 0) & ",bytShowNegivate=" & mintFormatNegative _
            & ",dblTopMargin =" & mlngPaperBorder(0) & ",dblBottomMargin =" & mlngPaperBorder(1) & ",dblLeftMargin =" & mlngPaperBorder(2) & ",dblRightMargin =" & mlngPaperBorder(3) _
            & " WHERE lngPrintSetupID=" & mlngPrintSetupID
        gclsBase.ExecSQL strSQL
    Else
        If mintPaperTypeIndex1 = 0 Then '如果是默认纸张时,直接改变其打印对象的纵横属性
            Printer.Orientation = IIf(mblnPortrait, 1, 2)
        End If
        '再找一次打印设置是否为预置
        If mblnPreSet Then
            strSQL = "SELECT lngPrintSetupID FROM Report WHERE lngReportID=" & mlngReportID
            Set rstFind = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
            If rstFind!lngPrintSetupID = 0 Then
                '复制打印设置记录
                mlngPrintSetupID = GetPrintSetupID
                mblnPreSet = False
            End If
        End If
        '提交字体表
        For intCount = 0 To 4
            strSQL = "UPDATE Font SET strFontName='" & mfntPropertiy(intCount).Name & "',dblSize=" & mfntPropertiy(intCount).Size & ",intCharSet=" & mfntPropertiy(intCount).Charset _
                & ",blnIsBold =" & IIf(mfntPropertiy(intCount).Bold, 1, 0) & ",blnIsItalic =" & IIf(mfntPropertiy(intCount).Italic, 1, 0) & ",blnIsStrikeThrough =" & IIf(mfntPropertiy(intCount).Strikethrough, 1, 0) & ",blnISUnderLine=" & IIf(mfntPropertiy(intCount).UnderLine, 1, 0) _
                & " WHERE lngFontID=" & mlngFontID(intCount)
            gclsBase.ExecSQL strSQL
        Next intCount
        '提交打印设置表
        strSQL = "lngZoomScale=" & mintZoomScale & ",intPageZoomChoose=" & mintPageZoom _
            & ",intPageSetupType=" & mbytPageSetup & ",dblRowDistance=" & mlngHeightPerRow * 56.7 / Screen.TwipsPerPixelY _
            & ",lngPaperRow=" & mintRowsPerPage + 3 & ",blnIsNeedSeprateLine=" & IIf(mblnNeedSeprateLine, 1, 0) _
            & ",lngRowLine=" & mintLineSpace & ",blnIsFillEmptyRow=" & IIf(mblnFooterAlign, 1, 0)
        strSQL = strSQL & ",blnIsCashLine=" & IIf(mblnShowMoneyLine, 1, 0) & ",blnIsShowZero=" & IIf(mblnShowNotZero, 1, 0) _
            & ",blnIsShowSeprate=" & IIf(mblnShowSeprate, 1, 0) & ",bytShowNegivate=" & mintFormatNegative
        strSQL = strSQL & ",lngPaperSize=" & mintPaperTypeIndex1 & ",intPaperSizeIndex=" & mintPaperIndex _
            & ",lngPaperWidth=" & mlngPaperWidth & ",lngPaperLength=" & mlngPaperHeight _
            & ",lngOrientation=" & IIf(mblnPortrait, 1, 2)
        strSQL = strSQL & ",dblTopMargin =" & mlngPaperBorder(0) & ",dblBottomMargin =" & mlngPaperBorder(1) _
            & ",dblLeftMargin =" & mlngPaperBorder(2) & ",dblRightMargin =" & mlngPaperBorder(3) _
            & ",dblHeaderMargin =" & mlngPaperBorder(4) & ",dblFooterMargin =" & mlngPaperBorder(4) _
            & ",dblBindingMargin =" & mlngPaperBorder(6) & ",blnIsUpBinding =" & mintBindPosition _
            & ",blnIsHorizontalMiddle =" & IIf(mblnHoriCentre, 1, 0) & ",blnIsVerticalMiddle =" & IIf(mblnVertCenter, 1, 0)
        strSQL = strSQL & ",strPageHeaderLeft ='" & mstrHeader(0) & "',strPageHeaderMiddle ='" & mstrHeader(1) _
            & "',strPageHeaderRight ='" & mstrHeader(2) & "',strPageFooterLeft ='" & mstrFooter(0) _
            & "',strPageFooterMiddle ='" & mstrFooter(1) & "',strPageFooterRight ='" & mstrFooter(2) _
            & "',intOutFrameStyle =" & mintFrameStyle & ",intOutFrameLintType =" & mintFrameLine
        strSQL = strSQL & ",lngRowSeprateColor =" & mlngBorderColor(0) & ",lngColSeprateColor =" & mlngBorderColor(1) _
            & ",lngOutFrameColor =" & mlngBorderColor(2) & ",intRowSeprateWidth =" & mintBorderWidth(0) _
            & ",intColSeprateWidth =" & mintBorderWidth(1) & ",intOutFrameWidth =" & mintBorderWidth(2)
        strSQL = strSQL & ",lngTitleColor =" & mlngFontColor(0) & ",lngTextColor =" & mlngFontColor(1) _
            & ",lngPageHFeaderColor =" & mlngFontColor(2) & ",lngTableHFooterColor =" & mlngFontColor(3) _
            & ",lngColumnCaptionColor =" & mlngFontColor(4)
        strSQL = strSQL & ",lngTitleBackColor =" & mlngFontBKColor(0) & ",lngTextBackColor =" & mlngFontBKColor(1) _
            & ",lngPageHFeaderBackColor =" & mlngFontBKColor(2) & ",lngTableHFooterBackColor =" & mlngFontBKColor(3) _
            & ",lngColumnCaptionBackColor =" & mlngFontBKColor(4)
        strSQL = "UPDATE PrintSetup SET " & strSQL & " WHERE lngPrintSetupID=" & mlngPrintSetupID
        gclsBase.ExecSQL strSQL
    End If
    Set rstFind = Nothing
End Sub

Public Sub SaveBindingMargin(ByVal lngPrintSetupID As Long, ByVal dblValue As Double)
Dim strSQL As String
    strSQL = "UPDATE PrintSetup Set dblBindingMargin=" & dblValue & "  Where lngPrintSetupID = " & lngPrintSetupID
    gclsBase.ExecSQL strSQL
End Sub


'根据旧打印设置ID复制一个新的,并返回新设置ID
Private Function GetPrintSetupID() As Long
Dim rstSource As rdoResultset
Dim rstTarget As rdoResultset
Dim strSQL As String
Dim lngFontID(5) As Long
Dim intCount As Integer
Dim fldField As rdoColumn
    '复制打印字体设置表
    On Error GoTo ErrHandle
    gclsBase.BaseDB.BeginTrans
     '关闭表触发器
    strSQL = "Alter Table Font Disable All Triggers"
    gclsBase.BaseDB.Execute (strSQL)
    
    strSQL = "Select * From Font Where lngFontID =-1"
    Set rstTarget = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenDynamic, rdConcurValues)
    With rstTarget
        For intCount = 0 To 4
            strSQL = "Select * From Font Where lngFontID =" & mlngFontID(intCount)
            Set rstSource = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
            .AddNew
            For Each fldField In rstSource.rdoColumns
                If UCase(fldField.Name) = UCase("lngFontID") Then
                    lngFontID(intCount) = BillPublic.GetNewID("Font")
                    .rdoColumns(fldField.Name).Value = lngFontID(intCount)
                Else
                    .rdoColumns(fldField.Name).Value = fldField.Value
                End If
            Next
            .Update
        Next intCount
    End With
     '打开表触发器
    strSQL = "Alter Table Font Enable All Triggers"
    gclsBase.BaseDB.Execute (strSQL)
     '关闭表触发器
    strSQL = "Alter Table PrintSetup Disable All Triggers"
    gclsBase.BaseDB.Execute (strSQL)
    
    '复制打印设置表
    strSQL = "Select * From PrintSetup Where lngPrintSetupID =" & mlngPrintSetupID
    Set rstSource = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    strSQL = "Select * From PrintSetup Where lngPrintSetupID =-1"
    Set rstTarget = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenDynamic, rdConcurValues)
    With rstTarget
        .AddNew
        For Each fldField In rstSource.rdoColumns
            Select Case UCase(fldField.Name)
            Case UCase("lngPrintSetupID")
                mlngPrintSetupID = BillPublic.GetNewID("PrintSetup")
                 .rdoColumns(fldField.Name).Value = mlngPrintSetupID
            Case UCase("lngTitleFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(0)
            Case UCase("lngTextFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(1)
            Case UCase("lngPageHeaderFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(2)
            Case UCase("lngTableHFooterFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(3)
            Case UCase("lngColumnCaptionFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(4)
            Case Else
                .rdoColumns(fldField.Name).Value = fldField.Value
            End Select
        Next
        .Update
    End With
      '打开表触发器
    strSQL = "Alter Table PrintSetup Enable All Triggers"
    gclsBase.BaseDB.Execute (strSQL)
    
    '提交打印设置ID
    strSQL = "UPDATE  Report Set lngPrintSetupID=" & mlngPrintSetupID & " Where lngReportID = " & mlngReportID
    gclsBase.ExecSQL strSQL
    gclsBase.BaseDB.CommitTrans
    For intCount = 0 To 4
        mlngFontID(intCount) = lngFontID(intCount)
    Next intCount
    GetPrintSetupID = mlngPrintSetupID
    
    Erase lngFontID
    Set rstSource = Nothing
    Set rstTarget = Nothing
    Exit Function
ErrHandle:
    gclsBase.BaseDB.RollBacktrans
    Erase lngFontID
    Set rstSource = Nothing
    Set rstTarget = Nothing
End Function