VB财务软件系统下载源代码提供自由下载使用学习

    lRet = Printer.SetDataStyleXML(sData, 1, sStyle, 1, sModuleId)
    If lRet = 0 Then
        prnDataBind = True
    Else
        prnDataBind = False
        MsgBox "打印数据准备失败！", vbInformation, "错误信息"
    End If
End Function
'打印处理程序
Private Sub printProc()
    If Not xmlInit Then
        Call initPrnXmlFile
    End If
    If xmlInit Then
        Printer.DoPrint
        xmlInit = False
    End If
End Sub
'预览处理程序
Private Sub previewProc()
    If Not xmlInit Then
        Call initPrnXmlFile
    End If
    If xmlInit Then
        Printer.PrintPreview
        xmlInit = False
    End If
End Sub
'输出处理程序
Private Sub outputProc()
    If Not xmlInit Then
        Call initPrnXmlFile
    End If
    If xmlInit Then
        Dim sTypeList As String
        Dim sSizeList As String
        Dim i As Long
        Dim e As Long
    
        i = 0
        sTypeList = "10,10,7"
        sSizeList = "40,36,18"
        e = Printer.ExportToFile(i, sTypeList, sSizeList, "", "")
        xmlInit = False
    '    MsgBox e
    End If
End Sub
'保存用户设置
Private Sub printer_SettingChanged(ByVal varLocalSettings As Variant, ByVal varModuleSettings As Variant)
    Dim xmlstr As String
    xmlstr = "<?xml version='1.0' standalone='yes' ?>"
    xmlstr = xmlstr & "<格式>"
    xmlstr = xmlstr & varLocalSettings
    xmlstr = xmlstr & varModuleSettings
    xmlstr = xmlstr & "</格式>"
    Dim rs As New ADODB.Recordset
    On Error GoTo error0
    rs.Open "select * from prn_format where moduleid='creClassprn'", con, adOpenDynamic, adLockOptimistic
    rs("formatXml") = xmlstr
    rs.Update
    'sqlstr = "insert into PRN_format (moduleID,FormatXml) values('autoReturn42','" & xmlstr & "');"
    rs.Close
    Set rs = Nothing
    Exit Sub
error0:
    rs.Close
    Set rs = Nothing
    MsgBox "打印设置保存失败！"
End Sub
'设置打印格式
Private Function initStyleXml() As Boolean
    Dim rs As New ADODB.Recordset
    Dim PrnDom As New DOMDocument
    Dim xmlstr As String
    Dim sqlstr As String
    sqlstr = "select formatXml from PRN_format where moduleID='creClassprn'"
    rs.Open sqlstr, con, adOpenDynamic, adLockOptimistic
    If Not (rs.EOF Or rs.BOF) Then
        xmlstr = Trim(rs("formatXml"))
    Else
        xmlstr = "<?xml version=''1.0'' standalone=''yes'' ?>"
        xmlstr = xmlstr & "<格式>"
        xmlstr = xmlstr & "<打印设置 打印范围=''全部'' 页码范围=''1-1'' 打印份数=''1'' 压缩=''是'' 多任务强制分页=''否'' />"
        xmlstr = xmlstr & "<纸张设置 纸张类型=''9'' 纸张大小=''2100,2970'' 打印方向=''纵向'' 页边距=''300,200,200,200'' />"
        xmlstr = xmlstr & "<页眉 对齐方式=''右'' 左顶点=''0,0'' 宽=''0'' 高=''100'' 字体名=''楷体_GB2312'' 字体大小=''12'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 打印=''是'' />"
        xmlstr = xmlstr & "<标题 对齐方式=''中'' 左顶点=''0,200'' 宽=''0'' 高=''300'' 字体名=''黑体'' 字体大小=''24'' 颜色=''#000000'' 粗体=''是'' 斜体=''否'' 打印=''是'' /> "
'        xmlstr = xmlstr & "<表头 对齐方式=''左'' 左顶点=''0,500'' 宽=''1600'' 高=''300'' 字体名=''宋体'' 字体大小=''12'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 打印=''是''>"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''单位名称'' 对齐方式=''左'' 左顶点=''1100,500'' 宽=''800'' 高=''200'' 字体名=''黑体'' 字体大小=''16'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 标题宽度=''0'' 下标线=''否'' />"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''日期'' 对齐方式=''右'' 左顶点=''1200,650'' 宽=''600'' 高=''140'' />"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''评价区间'' 对齐方式=''右'' 左顶点=''1200,650'' 宽=''600'' 高=''140'' />"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''实际得分'' 对齐方式=''右'' 左顶点=''1200,650'' 宽=''600'' 高=''140'' />"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''信用等级'' 对齐方式=''右'' 左顶点=''1200,650'' 宽=''600'' 高=''140'' />"
'        xmlstr = xmlstr & "</表头>"
        xmlstr = xmlstr & "<表体 左顶点=''0,800'' 宽=''0'' 高=''1400'' 固定行数=''0'' 列宽=''350,350,350''>"
        xmlstr = xmlstr & "<表体头 对齐方式=''中'' 边框风格=''735'' 边框宽度=''2'' 行高=''140'' 字体名=''黑体'' 字体大小=''14'' 颜色=''#000000'' 粗体=''是'' 斜体=''否'' 打印=''是'' />"
        xmlstr = xmlstr & "<表体行 对齐方式=''左,左,左'' 边框风格=''783'' 边框宽度=''2'' 行高=''0'' 字体名=''Times New Roman'' 字体大小=''12'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 打印=''是'' />"
        xmlstr = xmlstr & "<表体尾 对齐方式=''中'' 边框风格=''735'' 边框宽度=''2'' 行高=''140'' 字体名=''黑体'' 字体大小=''14'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 打印=''是'' />"
        xmlstr = xmlstr & "</表体>"
'        xmlstr = xmlstr & "<表尾 对齐方式=''左'' 左顶点=''0,2200'' 宽=''1600'' 高=''200'' 字体名=''新宋体'' 字体大小=''12'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 打印=''是''>"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''操作员'' 对齐方式=''左'' 左顶点=''50,2200'' 宽=''500'' 高=''200'' 字体名='''' 字体大小=''12'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 标题宽度=''0'' 下标线=''否'' />"
'        xmlstr = xmlstr & "<字段 打印=''是'' 名字=''操作日期'' 对齐方式=''右'' 左顶点=''800,2200'' 宽=''600'' 高=''150'' 字体名='''' 字体大小=''12'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 标题宽度=''0'' 下标线=''否'' />"
'        xmlstr = xmlstr & "</表尾>"
        xmlstr = xmlstr & "<页脚 对齐方式=''右'' 左顶点=''0,2400'' 宽=''0'' 高=''170'' 字体名=''楷体_GB2312'' 字体大小=''10'' 颜色=''#000000'' 粗体=''否'' 斜体=''否'' 打印=''是'' />"
        xmlstr = xmlstr & "</格式>"
        sqlstr = "insert into PRN_format (moduleID,FormatXml) values('creClassprn','" & xmlstr & "');"
        On Error GoTo Error1
        con.BeginTrans
        con.Execute sqlstr
        con.CommitTrans
        xmlstr = "<?xml version='1.0' standalone='yes' ?>"
        xmlstr = xmlstr & "<格式>"
        xmlstr = xmlstr & "<打印设置  打印范围='全部' 页码范围='1-1' 打印份数='1' 压缩='是' 多任务强制分页='否' />"
        xmlstr = xmlstr & "<纸张设置 纸张类型='9' 纸张大小='2100,2970' 打印方向='纵向' 页边距='300,200,200,200' />"
        xmlstr = xmlstr & "<页眉 对齐方式='右' 左顶点='0,0' 宽='0' 高='100' 字体名='楷体_GB2312' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "<标题 对齐方式='中' 左顶点='0,200' 宽='0' 高='300' 字体名='黑体' 字体大小='24' 颜色='#000000' 粗体='是' 斜体='否' 打印='是' /> "
'        xmlstr = xmlstr & "<表头 对齐方式='左' 左顶点='0,500' 宽='1600' 高='300' 字体名='宋体' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 打印='是'>"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='单位名称' 对齐方式='左' 左顶点='1100,500' 宽='800' 高='200' 字体名='黑体' 字体大小='16' 颜色='#000000' 粗体='否' 斜体='否' 标题宽度='0' 下标线='否' />"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='日期' 对齐方式='右' 左顶点='1200,650' 宽='600' 高='140' />"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='评价区间' 对齐方式='左' 左顶点='1100,500' 宽='800' 高='200' 字体名='黑体' 字体大小='16' 颜色='#000000' 粗体='否' 斜体='否' 标题宽度='0' 下标线='否' />"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='实际得分' 对齐方式='右' 左顶点='1200,650' 宽='600' 高='140' />"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='信用等级' 对齐方式='左' 左顶点='1100,500' 宽='800' 高='200' 字体名='黑体' 字体大小='16' 颜色='#000000' 粗体='否' 斜体='否' 标题宽度='0' 下标线='否' />"
'        xmlstr = xmlstr & "</表头>"
        xmlstr = xmlstr & "<表体 左顶点='0,800' 宽='0' 高='1400' 固定行数='0' 列宽='350,350,350'>"
        xmlstr = xmlstr & "<表体头 对齐方式='中' 边框风格='735' 边框宽度='2' 行高='140' 字体名='黑体' 字体大小='14' 颜色='#000000' 粗体='是' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "<表体行 对齐方式='左,左,左' 边框风格='783' 边框宽度='2' 行高='0' 字体名='Times New Roman' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "<表体尾 对齐方式='中' 边框风格='735' 边框宽度='2' 行高='140' 字体名='黑体' 字体大小='14' 颜色='#000000' 粗体='否' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "</表体>"
'        xmlstr = xmlstr & "<表尾 对齐方式='左' 左顶点='0,1800' 宽='1600' 高='200' 字体名='新宋体' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 打印='是'>"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='操作员' 对齐方式='左' 左顶点='50,1800' 宽='500' 高='200' 字体名='' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 标题宽度='0' 下标线='否' />"
'        xmlstr = xmlstr & "<字段 打印='是' 名字='操作日期' 对齐方式='右' 左顶点='800,1800' 宽='600' 高='150' 字体名='' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 标题宽度='0' 下标线='否' />"
'        xmlstr = xmlstr & "</表尾>"
        xmlstr = xmlstr & "<页脚 对齐方式='右' 左顶点='0,2400' 宽='0' 高='170' 字体名='楷体_GB2312' 字体大小='10' 颜色='#000000' 粗体='否' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "</格式>"

    End If

    If PrnDom.loadXML(Trim(xmlstr)) Then
        PrnDom.Save App.Path & "\tcreClassStyle.xml"
    Else
       initStyleXml = False
    End If
    initStyleXml = True
    
    rs.Close
    Set rs = Nothing
    Set PrnDom = Nothing
    Exit Function
Error1:
    initStyleXml = False
    con.RollbackTrans
    rs.Close
    Set rs = Nothing
    Set PrnDom = Nothing
End Function
'检查是否已有冲突窗体打开
Public Function check_open_Form() As Boolean
    If credstat.proctype = "jldj" Then
    
    Else
       Select Case credstat.proctype
            Case "jlzb"
                 MsgBox "您已打开评价指标窗口！" & vbCrLf & "请先关闭评价指标窗口！"
                 duplicate = True
                 check_open_Form = False
                 'Unload Me
                 Exit Function
            Case "xypj"
                 MsgBox "您已打开了信用评价窗口！" & vbCrLf & "请先关闭信用评价窗口！"
                 duplicate = True
                 check_open_Form = False
                 'Unload Me
                 Exit Function
            Case "dked"
                 MsgBox "您已打开贷款额度窗口！" & vbCrLf & "请先关闭贷款额度窗口！"
                 duplicate = True
                 check_open_Form = False
                 'Unload Me
                 Exit Function
            Case "jldj"
                 MsgBox "您已打开了信用等级窗口！" & vbCrLf & "请先关闭信用等级窗口！"
                 duplicate = True
                 check_open_Form = False
                 'Unload Me
                 Exit Function
        End Select
    End If
        duplicate = False
        check_open_Form = True
        credstat.proctype = ""

End Function

'检查输入信用等级
Private Function check_creClass(ByVal i As Integer) As Boolean
    With SuperGrid1
        If .Rows > 2 Then
            If i <> 1 Then
                If .TextMatrix(i, 1) <> .TextMatrix(i - 1, 2) Then
                    .TextMatrix(i, 1) = .TextMatrix(i - 1, 2)
                End If
            End If
        End If
        If i <> .Rows - 1 Then
            If CDbl(.TextMatrix(i, 1)) > CDbl(.TextMatrix(i, 2)) Then
                MsgBox "第" & i & "行输入错误！" & "上限不能小于下限！", vbInformation, ""
                .row = i
                .col = 2
                .SetFocus
                check_creClass = False
                Exit Function
            End If
        Else
            .TextMatrix(i, 2) = ""
            '.TextMatrix(i, 2) = ">" & .TextMatrix(i, 1)
        End If
        check_creClass = True
    End With
End Function


Private Sub loadstatic()
   Picture1.Align = 0
   Picture1.width = ZjAccInfo.zjPictWidth
   Picture1.Picture = LoadPicture(ZjAccInfo.zjRepPath & "BookBack.BMP")

    ImageList1.ListImages.Add , "print", LoadResPicture(314, vbResBitmap)
    ImageList1.ListImages.Add , "preview", LoadResPicture(312, vbResBitmap)
    ImageList1.ListImages.Add , "Output", LoadResPicture(263, vbResBitmap)
    ImageList1.ListImages.Add , "Modi", LoadResPicture(324, vbResBitmap)
    ImageList1.ListImages.Add , "addColumn", LoadResPicture(343, vbResBitmap)
    ImageList1.ListImages.Add , "delColumn", LoadResPicture(347, vbResBitmap)
    ImageList1.ListImages.Add , "Cancel", LoadResPicture(316, vbResBitmap)
    ImageList1.ListImages.Add , "Save", LoadResPicture(1145, vbResBitmap)
    ImageList1.ListImages.Add , "estModal", LoadResPicture(313, vbResBitmap)
    ImageList1.ListImages.Add , "Help", LoadResPicture(396, vbResBitmap)
    ImageList1.ListImages.Add , "Exit", LoadResPicture(1118, vbResBitmap)


    With tlbTool
        .Buttons("print").Caption = "打印"
        .Buttons("print").Image = "print"
        .Buttons("print").ToolTipText = "Ctrl+P"
        
        .Buttons("preview").Caption = "预览"
        .Buttons("preview").Image = "preview"
        .Buttons("preview").ToolTipText = "Ctrl+V"
        
        .Buttons("Output").Caption = "输出"
        .Buttons("Output").Image = "Output"
        .Buttons("Output").ToolTipText = "Ctrl+O"
        
        .Buttons("Modi").Caption = "修改"
        .Buttons("Modi").Image = "Modi"
        '.Buttons("Modi").ToolTipText = "F12"
        .Buttons("Modi").ToolTipText = ""
        
        .Buttons("addColumn").Caption = "增行"
        .Buttons("addColumn").Image = "addColumn"
        .Buttons("addColumn").ToolTipText = "Ctrl+I"
        
        .Buttons("delColumn").Caption = "删行"
        .Buttons("delColumn").Image = "delColumn"
        .Buttons("delColumn").ToolTipText = "Ctrl+D"
        
        .Buttons("estModal").Caption = "模型"
        .Buttons("estModal").Image = "estModal"
        .Buttons("estModal").ToolTipText = "Ctrl+M"
        
        .Buttons("Cancel").Caption = "放弃"
        .Buttons("Cancel").Image = "Cancel"
        .Buttons("Cancel").ToolTipText = "Ctrl+Z"
        
        .Buttons("Save").Caption = "保存"
        .Buttons("Save").Image = "Save"
        .Buttons("Save").ToolTipText = "F6"
        
        .Buttons("Help").Image = "Help"
        .Buttons("Help").Caption = "帮助"
        .Buttons("Help").ToolTipText = "F1"

        .Buttons("Exit").Image = "Exit"
        .Buttons("Exit").Caption = "退出"
        .Buttons("Exit").ToolTipText = "Ctrl+F4"

     End With

End Sub

Private Function show_estModal() As Boolean
    Dim result As VbMsgBoxResult
    show_estModal = False
    If credstat.modified Then
        result = MsgBox("您还有数据未保存，是否决定在退出信用评价程序前保存数据？", vbYesNoCancel, "退出程序")
        Select Case result
         Case vbYes
             If SaveData Then
                show_estModal = True
                credstat.ModifyState = 0
                credstat.modified = False
             Else
                show_estModal = False
                Exit Function
             End If
        Case vbNo
                show_estModal = True
                credstat.ModifyState = 0
                credstat.modified = False
        Case vbCancel
                show_estModal = False
                Exit Function
        End Select
    Else
        show_estModal = True
    End If
End Function