贷款额度.frm

用友U8财务软件VB源程序, 本版本为2002年版本

'            RS.AddNew
'            RS("cUnitcode") = unitInfor(curPos, 0)
'            RS("perStart") = DateCheck(.TextMatrix(.Rows - 1, 0))
'            RS("perEnd") = DateCheck(.TextMatrix(.Rows - 1, 1))
'            RS("borLimValue") = .TextMatrix(.Rows - 1, 2)
'            RS("bType") = j
            con.Execute sqlstr
            For i = 2 To .Rows - 1
                sqlstr = "insert into fd_borQuaLimSet (cUnitcode,avalDateStart,avalDateEnd,borLimValue,btype) values('"
                sqlstr = sqlstr & unitInfor(curPos, 0) & "','" & DateCheck(.TextMatrix(i, 0)) & "','" & DateCheck(.TextMatrix(i, 1)) & "',"
                sqlstr = sqlstr & .TextMatrix(i, 2) & "," & j & ");"
                con.Execute sqlstr
            Next
            con.CommitTrans
        Case 2  '修改数据
'            sqlStr = "select * from FD_borQuaLimSet where cUnitCode=" & unitInfor(curPos, 0) & " order by perStart"
'            RS.Open sqlStr, con, adOpenDynamic
'            For i = 3 To .Rows - 1
'                RS("cUnitcode") = unitInfor(curPos, 0)
'                RS("perStart") = DateCheck(.TextMatrix(i, 0))
'                RS("perEnd") = DateCheck(.TextMatrix(i, 1))
'                RS("borLimValue") = .TextMatrix(i, 2)
'                RS("bType") = j
'                RS.MoveNext
'            Next
'            RS.UpdateBatch
            con.BeginTrans
            sqlstr = "delete from FD_borQuaLimSet where cUnitCode='" & unitInfor(curPos, 0) & "'"
'            RS.Open sqlStr, con, adOpenDynamic
'            RS.AddNew
'            RS("cUnitcode") = unitInfor(curPos, 0)
'            RS("perStart") = DateCheck(.TextMatrix(.Rows - 1, 0))
'            RS("perEnd") = DateCheck(.TextMatrix(.Rows - 1, 1))
'            RS("borLimValue") = .TextMatrix(.Rows - 1, 2)
'            RS("bType") = j
            con.Execute sqlstr
            For i = 2 To .Rows - 1
                sqlstr = "insert into fd_borQuaLimSet (cUnitcode,avalDateStart,avalDateEnd,borLimValue,btype) values('"
                sqlstr = sqlstr & unitInfor(curPos, 0) & "','" & DateCheck(.TextMatrix(i, 0)) & "','" & DateCheck(.TextMatrix(i, 1)) & "',"
                sqlstr = sqlstr & .TextMatrix(i, 2) & "," & j & ");"
                con.Execute sqlstr
            Next
            con.CommitTrans
        End Select
    End With
'    con.CommitTrans
'    RS.Close
'    Set RS = Nothing
    SaveData = True
    Exit Function
error0:
    con.RollbackTrans
    'RS.Close
    'Set RS = Nothing
    SaveData = False
    Exit Function
End Function

'保存数据处理过程
Private Sub saveProc()
    If CheckData Then
        If SaveData Then
            loadData (curPos)
            setQueryState
            fillgrid
        Else
            MsgBox "保存数据失败！", vbInformation, "保存数据"
       End If
    End If
End Sub

'初始化打印数据XML文件
Private Sub initPrnXmlFile()
    '过程变量
    Dim prnxml As New clsPrnXml
    Dim AttrName() As String
    Dim AttrValue() As String
    Dim i, j As Integer
    Dim str1 As String
    
    On Error GoTo error0
    
    '插入结构数据数据
    str1 = "贷款额度"
    prnxml.Initialize "数据", "任务"
    prnxml.InsertPNode "任务", "页眉", "第%p页，共%p页"
    prnxml.InsertPNode "任务", "标题", str1
    prnxml.InsertPNode "任务", "表头", ""
    prnxml.InsertPNode "任务", "表体", ""
    prnxml.InsertPNode "任务", "表尾", ""
    prnxml.InsertPNode "任务", "页脚", "用友软件"
    
    ReDim AttrName(0, 1)
    ReDim AttrValue(0)
    
    '插入表头,表尾数据
    For i = 0 To UBound(AttrName)
        AttrName(i, 0) = "名字"
    Next
    '插入表头,表尾数据
    AttrName(0, 1) = "日期"
    'AttrName(1, 1) = "单据名称"
    
    AttrValue(0) = CStr(Format(Date, "YYYY-MM-DD"))
    'AttrValue(1) = Trim(Txtdjmc.Text)
    prnxml.InsertHeadNodes "表头", "字段", AttrName, AttrValue
'    ReDim AttrName(1, 1)
'    ReDim AttrValue(1)
'    For i = 0 To UBound(AttrName)
'        AttrName(i, 0) = "名字"
'    Next
'
'    AttrName(0, 1) = "操作员"
'    AttrName(1, 1) = "操作日期"
'
'    AttrValue(0) = Trim(TxtcUsername.Text)
'    AttrValue(1) = CStr(Format(CDate(Trim(TxtOprDate.Text)), "YYYY-MM-DD"))
'    prnxml.InsertHeadNodes "表尾", "字段", AttrName, AttrValue
    
    '插入表体头数据
    ReDim AttrName(4, 1)
    ReDim AttrValue(4)
    For i = 0 To 4
        AttrName(i, 0) = "单元"
    Next
    AttrValue(0) = "单位类型"
    AttrValue(1) = "单位名称"
    AttrValue(2) = "有效期限(下限)"
    AttrValue(3) = "有效期限(上限)"
    AttrValue(4) = "贷款额度"
'    AttrValue(5) = "备注"
    prnxml.InsertBodyNodes "表体", "表体头", AttrName, AttrValue
    For i = 0 To 4
        AttrValue(i) = ""
    Next
    
    '插入表体行数据
    With SuperGrid1
        For i = 0 To .Rows - 3
        '插入表体行数据
            AttrValue(0) = Trim(LblUnitType.Caption)
            AttrValue(1) = Trim(lblUnitName.Caption)
            AttrValue(2) = .TextMatrix(i + 2, 0)
            AttrValue(3) = .TextMatrix(i + 2, 1)
            AttrValue(4) = .TextMatrix(i + 2, 2)
            prnxml.InsertBodyNodes "表体", "表体行", AttrName, AttrValue
        Next
    End With
    
    
'    Dim rs As New ADODB.Recordset
'    Dim sqlstr As String
'    sqlstr = "select DISTINCT a.cunitcode,a.avaldatestart,a.avaldateend,a.borlimvalue,a.memo,fd_accUnit.itype,fd_accunit.cunitname from fd_borqualimset A ,fd_borQualimset inner join fd_accunit on fd_accunit.cunitcode=fd_borqualimset.cUnitcode where a.avaldatestart IN (select MAX(avaldatestart) from fd_borqualimset b where ((b.cunitcode in (select distinct cunitcode from fd_borqualimset)) AND (A.CUNITCODE=FD_ACCUNIT.CUNITCODE)) GROUP BY B.CUNITCODE)"
'    rs.Open sqlstr, con, adOpenDynamic, adLockOptimistic
'    Dim data_empty As Boolean
'    data_empty = True
'    While Not (rs.EOF Or rs.BOF)
'        If Not IsNull(rs("Itype")) Then
'            Select Case CInt(Trim(rs("iType")))
'                Case 0
'                    AttrValue(0) = "个人"
'                Case 1
'                    AttrValue(0) = "部门"
'                Case 2
'                    AttrValue(0) = "银行"
'                Case 3
'                    AttrValue(0) = "客户"
'                Case 4
'                    AttrValue(0) = "供应商"
'                Case 4
'                    AttrValue(0) = "项目"
'            End Select
'        Else
'            AttrValue(0) = ""
'        End If
'        AttrValue(1) = IIf(IsNull(rs("cunitname")), "", rs("cunitname"))
'        AttrValue(2) = IIf(IsNull(rs("avaldateStart")), "", rs("avaldatestart"))
'        AttrValue(3) = IIf(IsNull(rs("avaldateend")), "", rs("avaldateend"))
'        AttrValue(4) = IIf(IsNull(rs("borlimvalue")), "", rs("borlimvalue"))
'        AttrValue(5) = IIf(IsNull(rs("memo")), "", rs("memo"))
'        rs.MoveNext
'        prnxml.InsertBodyNodes "表体", "表体行", AttrName, AttrValue
'        data_empty = False
'    Wend
'    '保存数据文件
'    If data_empty Then
'        data_empty = False
'        xmlInit = False
'        MsgBox "目前没有已定义的贷款额度数据", vbInformation, "系统信息"
'        Exit Sub
'    End If
    prnxml.saveFile "tborData.xml"
    If initStyleXml Then
        If prnDataBind Then
            xmlInit = True
        Else
            xmlInit = False
        End If
    Else
        xmlInit = False
    End If
    Set prnxml = Nothing
    Exit Sub
error0:
    MsgBox "打印数据准备失败！" & vbCrLf & Err.Description, vbInformation, "错误信息"
'    If rs.State = adStateOpen Then
'        rs.Close
'    End If
    xmlInit = False
    Set prnxml = Nothing
End Sub

Private Function prnDataBind() As Boolean
    Dim lRet As Long
    Dim sData As String
    Dim sStyle As String
    Dim sModuleId As String
    
    sData = App.Path & "\tbordata.xml"
    sStyle = App.Path & "\tborStyle.xml"
    sModuleId = "default"
    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()
    Dim i As Long
    With SuperGrid1
        For i = 2 To .Rows - 1
            If Trim(.TextMatrix(i, 0)) = "" Or Trim(.TextMatrix(i, 1)) = "" Or Trim(.TextMatrix(i, 2)) = "" Then Exit Sub
        Next
    End With
    If Not xmlInit Then
        Call initPrnXmlFile
    End If
    If xmlInit Then
        Dim sTypeList As String
        Dim sSizeList As String
        Dim e As Long
    
        i = 0
        sTypeList = "10,10,8,8,7"
        sSizeList = "10,40,8,8,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='loansetprn'", 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:
    If rs.State = adStateOpen Then
        rs.Close
    End If
    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
    
    sqlstr = "select formatXml from PRN_format where moduleID='loansetprn'"
    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 & "</表头>"
        xmlstr = xmlstr & "<表体 左顶点=''0,800'' 宽=''0'' 高=''1400'' 固定行数=''0'' 列宽=''250,220,350,350,300,400''>"
        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('loansetprn','" & 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' 颜色=