评价模型.frm

财务信息管理系统,适合做毕业论文的人使用

    
    sData = App.Path & "\tcreEstModalData.xml"
    sStyle = App.Path & "\tcreEstModalStyle.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()
    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,10,10,7,10,10"
        sSizeList = "80,10,120,8,18,120,80"
        e = Printer.ExportToFile(i, sTypeList, sSizeList, "", "")
        xmlInit = False
    '    MsgBox e
    End If
End Sub

Private Sub ocxCtbtool_OnCommand(ByVal enumType As prjTBCtrl.ENUM_MENU_OR_BUTTON, ByVal cButtonId As String, ByVal cMenuId As String)
    tlbTool_ButtonClick tlbTool.Buttons(cButtonId)
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='creEstModalprn'", 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='creEstModalprn'"
    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,350,100''>"
        xmlstr = xmlstr & "<表体头 对齐方式=''中'' 边框风格=''783'' 边框宽度=''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('creEstModalprn','" & 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 & "</表头>"
        xmlstr = xmlstr & "<表体 左顶点='0,800' 宽='0' 高='1400' 固定行数='0' 列宽='250,220,350,350,300,350,100'>"
        xmlstr = xmlstr & "<表体头 对齐方式='中' 边框风格='783' 边框宽度='2' 行高='140' 字体名='黑体' 字体大小='14' 颜色='#000000' 粗体='是' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "<表体行 对齐方式='左,左,左,左,左,左' 边框风格='783' 边框宽度='2' 行高='0' 字体名='Times New Roman' 字体大小='12' 颜色='#000000' 粗体='否' 斜体='否' 打印='是' />"
        xmlstr = xmlstr & "<表体尾 对齐方式='中' 边框风格='0' 边框宽度='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
'    Dim i As Integer
'    Dim s As String
'        i = 0
'    While i < Len(xmlstr)
'        s = mID(xmlstr, i + 1, 1)
'        If s = ">" Then
'            MsgBox s
'        End If
'        If mID(xmlstr, i + 1, 1) = Chr(34) Then
'            Mid(xmlstr, i + 1, 1) = "'"
'        End If
'        If mID(xmlstr, i + 1, 1) = Chr(13) Then
'            Mid(xmlstr, i + 1, 1) = ""
'        End If
'        If mID(xmlstr, i + 1, 1) = Chr(10) Then
'            Mid(xmlstr, i + 1, 1) = ""
'        End If
'        i = i + 1
'    Wend
'    MsgBox xmlstr
    If PrnDom.loadXML(Trim(xmlstr)) Then
        PrnDom.Save App.Path & "\tcreEstModalStyle.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

Private Sub cmdUp_Click()
    Dim i As Integer
    Dim temp As String
    SuperGrid1.ProtectUnload
    With SuperGrid1
    If credstat.selRow = 1 Then
        cmdUp.Enabled = False
        If SuperGrid1.Rows > 2 Then
            CmdDown.Enabled = True
        Else
            CmdDown.Enabled = False
        End If
        Exit Sub
    End If
    
    temp = ""
    For i = 0 To 7
        temp = .TextMatrix(credstat.selRow, i)
        '.TextMatrix(credstat.selRow, i) = creData(credstat.selRow - 2, i)
        .TextMatrix(credstat.selRow, i) = .TextMatrix(credstat.selRow - 1, i)
        '.TextMatrix(credstat.selRow - 1, i) = creData(credstat.selRow - 1, i)
        .TextMatrix(credstat.selRow - 1, i) = temp
    Next
    
    temp = ""
    For i = 0 To 8
        temp = creData(credstat.selRow - 2, i)
        creData(credstat.selRow - 2, i) = creData(credstat.selRow - 1, i)
        creData(credstat.selRow - 1, i) = temp
    Next
     credstat.selRow = credstat.selRow - 1
    .row = credstat.selRow
    .col = credstat.selcol
    .SetFocus

    End With
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    
    Select Case KeyCode
        Case vbKeyF6
            If Shift = 0 And tlbTool.Buttons("Save").Enabled Then
                SuperGrid1.ProtectUnload
                Call saveProc
            End If
'        Case vbKeyF3
'            If Shift = 0 And tlbtool.Buttons("linkquery").Enabled Then
'                Call linkqueryproc
'            End If
       Case vbKeyF4
            If Shift = 2 Then
                Unload Me
                Exit Sub
'            ElseIf Shift = 0 And tlbtool.Buttons("Cancel").Enabled Then
'                Call CancelProc
            End If
'        Case vbKeyF12
'            If Shift = 0 And tlbtool.Buttons("Modi").Enabled Then
'                Call ModiProc
'            End If
        Case vbKeyP
            If Shift = 2 And tlbTool.Buttons("print").Enabled Then
                Call printProc
            End If
        Case vbKeyO
            If Shift = 2 And tlbTool.Buttons("Output").Enabled Then
                Call outputProc
            End If
        Case vbKeyV
            If Shift = 4 And tlbTool.Buttons("preView").Enabled Then
                Call previewProc
            End If
        Case vbKeyR
            If Shift = 4 And tlbTool.Buttons("creClass").Enabled Then
                SuperGrid1.ProtectUnload
                If show_creClass Then
                    If frmcreClass.check_open_Form Then
                        Unload Me
                        frmcreClass.Show
                    End If
                End If
            End If
       Case vbKeyZ
            If Shift = 2 And tlbTool.Buttons("Cancel").Enabled Then
                CancelProc
            End If
        Case vbKey1
            If Shift = 2 And tlbTool.Buttons("SelAll").Enabled Then
                SuperGrid1.ProtectUnload
                SelAllProc
            End If
        Case vbKey2
            If Shift = 2 And tlbTool.Buttons("Unsel").Enabled Then
                SuperGrid1.ProtectUnload
                UnselProc
            End If
        Case vbKey3
            If Shift = 2 And tlbTool.Buttons("SelRow").Enabled Then
                SuperGrid1.ProtectUnload
                SelRowProc
            End If
        Case vbKey4
            If Shift = 2 And tlbTool.Buttons("cancelSel").Enabled Then
                SuperGrid1.ProtectUnload
                cancelSelProc
            End If
    End Select
    ocxCtbTool.RefreshEnable
End Sub

Private Sub Form_Load()
    Dim i As Integer
    
    loadstatic
    
    If credstat.proctype = "" Then credstat.proctype = "jlmx"
    
    con.ConnectionString = zjLogInfo.UfDbName
    con.CursorLocation = adUseClient
    con.Open
    
    SuperGrid1.Cols = 8
    SuperGrid1.ReadOnly = True
    
    SetTBStyle Me
    
    'If credstat.proctype = "jlmx" Then
    getOrderString
    Call sgsize
    
    With SuperGrid1
        If colwidth(0) = -10 Or (colwidth(0) = 0 And colwidth(1) = 0 And colwidth(2) = 0 And colwidth(3) = 0 And colwidth(4) = 0 And colwidth(5) = 0 And colwidth(6) = 0 And colwidth(7) = 0) Then
            .colwidth(0) = 450
            .colwidth(1) = 1800
            .colwidth(2) = 1100
            .colwidth(3) = 3600
            .colwidth(4) = 650
            .colwidth(5) = 650
            .colwidth(6) = 3600
            .colwidth(7) = 1600
        Else
            For i = 0 To 7
                .colwidth(i) = colwidth(i)
            Next
        End If
    End With
    
    Call Loaddatatosg
    
    cmdUp.Enabled = False
    CmdDown.Enabled = False
    
    ocxCtbTool.RefreshEnable
End Sub
'定义grid的规格
Private Sub sgsize()
    Dim i As Integer
    With SuperGrid1
        .width = Frame1.width - 300
        .Height = Frame1.Height - 100
        .left = Frame1.left + cmdUp.width + 100
        
        .SetColProperty 5, 18, DblBrowButton, EditDbl
        .FixedCols = 1
        .FixedRows = 1
        .ScrollBars = flexScrollBarBoth
        .TextMatrix(0, 0) = "选中"
        .TextMatrix(0, 1) = "评价指标名称"
        .TextMatrix(0, 2) = "评价指标性质"
        .TextMatrix(0, 3) = "计算公式(计算基准)"
        .TextMatrix(0, 4) = "标准值"
        .TextMatrix(0, 5) = "标准分"
        .SetColProperty 5, 12, BrowNull, EditDbl
        .TextMatrix(0, 6) = "计分公式(计分基准)"
        .TextMatrix(0, 7) = "备注"
        .SetColProperty 7, 120, , EditStr
        .AllowUserResizing = flexResizeColumns
        For i = 0 To 7
            Select Case i
                Case 0, 1, 2, 3, 6, 7
                    SuperGrid1.ColAlignment(i) = 1  '右对齐
                Case 4, 5
                    SuperGrid1.ColAlignment(i) = 6  '左对齐
            End Select
        Next