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

'    If rs.RecordCount = 0 Then
'        MsgBox "在已评价单位中，没有找到符合条件的单位！", vbInformation, "系统信息"
'    Else
'        ReDim cUnitCode(rs.RecordCount - 1)
'        credstat.Dxzbsm = rs.RecordCount
'        i = 0
'        While Not (rs.EOF Or rs.BOF)
'            cUnitCode(i) = rs("cunitcode")
'            i = i + 1
'            rs.MoveNext
'        Wend
'        curCursor = 0
'        loadData (cUnitCode(curCursor))
'        Call fillsgrid
'        Call setQueryState(0)
'     End If
End Sub

Private Sub CmdEstDateRef_Click()
    Dim Calendar As New CalendarAPP.ICaleCom
    Calendar.Caption = "评价时间"
    Calendar.DateDivideChar = "-"
    TxtestDate.Text = Calendar.Calendar(TxtestDate.hWnd)
    Set Calendar = Nothing
End Sub

Private Sub CmdperEndRef_Click()
    Dim Calendar As New CalendarAPP.ICaleCom
    'Calendar.Caption = "评价期间上限"
    Calendar.Caption = ""
    Calendar.DateDivideChar = "-"
    TxtperEnd.Text = Calendar.Calendar(TxtperEnd.hWnd)
    Set Calendar = Nothing
End Sub


Private Sub cmdperStartRef_Click()
    Dim Calendar As New CalendarAPP.ICaleCom
    'Calendar.Caption = "评价期间下限"
    Calendar.Caption = ""
    Calendar.DateDivideChar = "-"
    TxtperStart.Text = Calendar.Calendar(TxtperStart.hWnd)
    Set Calendar = Nothing
End Sub

Private Sub CmdUnitNameRef_Click()
    Dim rs1 As New ADODB.Recordset
    Dim rfd As New UFReferC.UFReferClient
    sqlstr = "select cUnitCode As 单位代码,cUnitName As 单位名称 from FD_AccUnit order by cUnitCode"
    'sqlstr = "select cUnitCode,cUnitName from FD_AccUnit order by cUnitCode;"
    rfd.SetLogin zjLogInfo
    rfd.SetReferSQLString sqlstr
    rfd.SetReferDisplayMode enuGrid
    rfd.Show
    If rfd.recmx Is Nothing Then Exit Sub
    Set rs1 = rfd.recmx
    TxtunitName.Text = rs1(1)
    TxtUnitCode.Text = rs1(0)
    Set rfd = Nothing
    Set rs1 = Nothing
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyF3
            If Shift = 0 And tlbTool.Buttons("search").Enabled Then
                Call queryproc
            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 vbKeyF5
            If Shift = 0 And tlbTool.Buttons("Estamate").Enabled Then
                Call estamateProc
            End If
        Case vbKeyF6
            If Shift = 0 And tlbTool.Buttons("Save").Enabled Then
                Call saveProc
            End If
'        Case vbKeyF12
'            If Shift = 0 And tlbTool.Buttons("Modi").Enabled Then
'                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 vbKeyPageUp
            If Shift = 4 And tlbTool.Buttons("firstEnt").Enabled Then
                firstEntProc
            ElseIf Shift = 0 And tlbTool.Buttons("prevEnt").Enabled Then
                prevEntProc
            End If
        Case vbKeyPageDown
            If Shift = 4 And tlbTool.Buttons("LastEnt").Enabled Then
                lastEntProc
            ElseIf Shift = 0 And tlbTool.Buttons("nextEnt").Enabled Then
                nextEntProc
            End If
        Case vbKeyZ
            If Shift = 2 And tlbTool.Buttons("Cancel").Enabled Then
                Call CancelProc
            End If
    End Select
    ocxCtbTool.RefreshEnable
End Sub

Private Sub Form_Load()
    '初始化处理
    loadstatic
    SetTBStyle Me
    getOrderString

    canExit = False
    sum_Realmark = 0
    
    con.ConnectionString = zjLogInfo.UfDbName
    con.CursorLocation = adUseClient
    con.Open
    
    SuperGrid1.Cols = 9
    
    '装载数据
    Call sgsize
    Call Initialize
    
'    If appendnew Or delold Then
'        MsgBox "系统中评价指标已发生变化！如未更新信用模型，请先更新信用模型！", vbInformation, "系统信息"
'    End If
    
    SuperGrid1.ReadOnly = True
    If canExit Then
        SuperGrid1.ReadOnly = True
        
        TxtunitName.Enabled = False
        CmdUnitNameRef.Enabled = False
        
        TxtestDate.Enabled = False
        CmdEstDateRef.Enabled = False
        
        TxtperStart.Enabled = False
        cmdperStartRef.Enabled = False
        
        TxtperEnd.Enabled = False
        CmdperEndRef.Enabled = False
            
        CmdEstDateRef.Visible = False
        CmdUnitNameRef.Visible = False
        cmdperStartRef.Visible = False
        CmdperEndRef.Visible = False

        With tlbTool
            .Buttons("firstEnt").Enabled = False
            .Buttons("prevEnt").Enabled = False
            .Buttons("nextEnt").Enabled = False
            .Buttons("LastEnt").Enabled = False
            .Buttons("Estamate").Enabled = False
            .Buttons("Modi").Enabled = False
            .Buttons("Cancel").Enabled = False
            .Buttons("Save").Enabled = False
            .Buttons("Help").Enabled = True
            .Buttons("Exit").Enabled = True
            .Buttons("search").Enabled = False
            .Buttons("print").Enabled = False
            .Buttons("preview").Enabled = False
            .Buttons("Output").Enabled = False
        End With
    End If
    
    ocxCtbTool.RefreshEnable
End Sub
'定义grid的规格
Private Sub sgsize()
Dim i As Integer
SuperGrid1.width = Me.width - 200
SuperGrid1.Height = Me.Height - TxtperEnd.top - TxtperEnd.Height - 300
SuperGrid1.left = tlbTool.left + 100
SuperGrid1.colwidth(0) = 1600
SuperGrid1.colwidth(1) = 1200
SuperGrid1.colwidth(2) = 3200
SuperGrid1.colwidth(3) = 650
SuperGrid1.colwidth(4) = 650
SuperGrid1.colwidth(5) = 650
SuperGrid1.colwidth(6) = 3200
SuperGrid1.colwidth(7) = 650
SuperGrid1.FixedCols = 1
SuperGrid1.FixedRows = 1
SuperGrid1.SetColProperty 3, 12, BrowNull, EditDbl, 4
For i = 0 To 8
    Select Case i
        Case 0, 1, 2, 6, 8
            SuperGrid1.ColAlignment(i) = 1  '右对齐
        Case 3, 4, 5, 7
            SuperGrid1.ColAlignment(i) = 6  '左对齐
    End Select
Next
End Sub

Private Sub Form_Resize()
    If Me.WindowState <> 1 Then
        If credstat.modified Then
            SuperGrid1.ProtectUnload
        End If
        Picture1.left = 0
        Picture1.width = Me.width
        SuperGrid1.top = TxtperEnd.top + TxtperEnd.Height + 200
        SuperGrid1.left = Picture1.left + 250
        Label7.left = Me.width / 2 - Label7.width / 2
        If Me.width > 100 Then
            SuperGrid1.width = Me.width - 400
        End If
        If Me.Height > TxtperEnd.top + TxtperEnd.Height + 300 Then
            SuperGrid1.Height = Me.Height - TxtperEnd.top - TxtperEnd.Height - 550
        End If
        SuperGrid1.left = Picture1.left + 100
    End If
    ResizeTlb Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim result As VbMsgBoxResult
    If credstat.modified Then
        result = MsgBox("您还有数据未保存，是否决定在退出评价模型程序时保存数据？", vbYesNoCancel, "退出程序")
        Select Case result
         Case vbYes
             'Call saveProc
             If SaveData Then
                Cancel = 0
             Else
                Cancel = 1
                Exit Sub
             End If
        Case vbNo
            Cancel = 0
        Case vbCancel
            Cancel = 1
            Exit Sub
        End Select
    Else
'        If MsgBox("确定要退出评价模型程序吗？", vbYesNo, "退出程序") = vbYes Then
'            Cancel = 0
'        Else
'            Cancel = 1
'            Exit Sub
'        End If
    End If
    'Con.Close
    Set con = Nothing

'    If Not duplicate Then
        Call clear
'    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 SuperGrid1_BrowUser(RetValue As String, ByVal R As Long, ByVal c As Long)
    Dim rs1 As New ADODB.Recordset
    Dim rfd As New UFReferC.UFReferClient
    rfd.SetLogin zjLogInfo
    rfd.SetReferSQLString "select standard As 标准,quaMark As 得分 from  FD_creEvaPara where itemName='" & _
            SuperGrid1.TextMatrix(R, 0) & "'   order by quaMark desc;"
    rfd.SetReferDisplayMode enuGrid
    rfd.Show
    If rfd.recmx Is Nothing Then Exit Sub
    Set rs1 = rfd.recmx
    RetValue = rs1(0)
    If SuperGrid1.TextMatrix(R, 7) <> "" Then
        sum_Realmark = sum_Realmark + rs1(1) - SuperGrid1.TextMatrix(R, 7)
    Else
        sum_Realmark = sum_Realmark + rs1(1)
    End If
    SuperGrid1.TextMatrix(R, 7) = rs1(1)
    SuperGrid1.Refresh
End Sub

Private Sub SuperGrid1_CellDataCheck(RetValue As String, RetState As MsSuperGrid.OpType, ByVal R As Long, ByVal c As Long)
    If credstat.ModifyState <> 0 Then
        If c = 3 Then
            If Trim(SuperGrid1.TextMatrix(R, c)) <> "" Then
                If SuperGrid1.TextMatrix(R, 1) <> "定性指标" Then
                    If CDbl(SuperGrid1.TextMatrix(R, c)) < 0 Then
                        If Not duplicate Then
                            MsgBox "实际值不允许为负数", vbInformation, "输入错误"
                            SuperGrid1.SetFocus
                            edit_error = True
                            error_num = 1
                        Else
                            duplicate = False
                        End If
                        'Exit Sub
                    End If
                        Call calmark
                    'End If
                Else
                    Call calmark
                End If
            End If
        End If
    End If
End Sub

Private Sub SuperGrid1_Click()
    credstat.selrow = SuperGrid1.row
    credstat.selcol = SuperGrid1.col
    If credstat.ModifyState <> 0 Then
        If SuperGrid1.col <> 3 Then
            SuperGrid1.ReadOnly = True
        Else
            SuperGrid1.ReadOnly = False
        End If
        If SuperGrid1.TextMatrix(SuperGrid1.row, 1) = "定性指标" And SuperGrid1.col = 3 Then
            SuperGrid1.SetColProperty 3, 12, UserBrowButton
        Else
            SuperGrid1.SetColProperty 3, 12, DblBrowButton, EditDbl
        End If
    End If
End Sub

Private Sub SuperGrid1_DblClick()
    credstat.selrow = SuperGrid1.row
    credstat.selcol = SuperGrid1.col
    If credstat.ModifyState <> 0 Then
        If SuperGrid1.col <> 3 Then
            SuperGrid1.ReadOnly = True
        Else
            SuperGrid1.ReadOnly = False
        End If
        If SuperGrid1.TextMatrix(SuperGrid1.row, 1) = "定性指标" And SuperGrid1.col = 3 Then
            SuperGrid1.SetColProperty 3, 12, UserBrowButton
        Else
            SuperGrid1.SetColProperty 3, 12, DblBrowButton, EditDbl
        End If
    Else
        SuperGrid1.ReadOnly = True
    End If
End Sub

Private Sub SuperGrid1_GotFocus()
    CmdEstDateRef.Visible = False
    CmdUnitNameRef.Visible = False
    cmdperStartRef.Visible = False
    CmdperEndRef.Visible = False
End Sub

Private Sub SuperGrid1_LostFocus()
    If credstat.ModifyState <> 0 Then
        If credstat.selcol = 3 Then
            If Trim(SuperGrid1.TextMatrix(credstat.selrow, credstat.selcol)) <> "" Then
                If SuperGrid1.TextMatrix(SuperGrid1.row, 1) <> "定性指标" Then