frmaccupgrade.frm

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

                sqlstr = "update fd_Vouch set Cacc1_id='" & .TextMatrix(i + 1, 1) & "' where Cacc1_id='" & .TextMatrix(i + 1, 0) & "'"
                con.Execute sqlstr
                sqlstr = "update fd_Vouch set Cacc2_id='" & .TextMatrix(i + 1, 1) & "' where Cacc2_id='" & .TextMatrix(i + 1, 0) & "'"
                con.Execute sqlstr
                Me.ProgressBar1.Value = .Rows - i - 1
                iResult = i Mod 10
                If iResult = 0 Then
                    DoEvents
                    Label8.Caption = "已处理" & .Rows - i - 1 & "条"
                End If

            Next
        End With
        Debug.Print "after insert " & Time
        con.CommitTrans
    
        SaveData = True
        Exit Function
    Else
        SaveData = False
        Exit Function
    End If
Error0:
    MsgBox Err.Description
    SaveData = False
    Exit Function
Error1:
    con.RollbackTrans
    MsgBox "保存失败", vbInformation, "账号升级"
    SaveData = False
'    If con.State = adStateOpen Then
'        con.Close
'    End If
'    Set con = Nothing
End Function

Private Sub saveProc()
    
    Dim result As VbMsgBoxResult
    result = MsgBox("保存升级信息之前，请退出资金管理其他应用！" & vbCrLf & "否则可能导致其他应用的数据错误！" & vbCrLf & "确定要保存吗！", vbYesNo, "保存数据")
    Select Case result
     Case vbYes
    Case vbNo
        Exit Sub
    End Select
    
    If SaveData Then
        'set toobool statues
        Frame2.Visible = False
        With tlbTool
            .Buttons("cmdyulan").Enabled = True
            .Buttons("print").Enabled = True
            .Buttons("preview").Enabled = True
            .Buttons("output").Enabled = True
            .Buttons("search").Enabled = True
            .Buttons("cancel").Enabled = False
            .Buttons("save").Enabled = False
        End With
        
        'set commondbutton statues
        'cmdYuLan.Enabled = True
        
        modified = False
        
        Call fillGrid(True)
        
    End If
    Frame2.Visible = False
End Sub

'check input data
Private Function CheckData() As Boolean
    Dim i As Long
    Dim j As Long
    Dim rsacc As New UfRecordset
    With SuperGrid1
'        For i = 1 To .Rows - 2
'            For j = i + 1 To .Rows - 1
'                If .TextMatrix(i, 1) = .TextMatrix(j, 0) Then
'                    MsgBox "错误！第" & i & "行新账户号与第" & j & "行旧账户号相同", vbInformation, "账号升级"
'                    CheckData = False
'                    Exit Function
'                End If
''                If .TextMatrix(i, 1) = .TextMatrix(j, 1) Then
''                    MsgBox "错误！第" & i & "行新账户号与第" & j & "行新账户号相同", vbInformation, "账号升级"
''                    CheckData = False
''                    Exit Function
''                End If
'            Next
'        Next
 Debug.Print "after check duplicate" & Time
        Frame2.Visible = True
        Frame2.top = Me.Height / 2 - Frame2.Height / 2
        Frame2.left = Me.width / 2 - Frame2.width / 2
        Label6.Caption = "正在做合法性校验！请等待......"
        Label7.Caption = "共有记录" & SuperGrid1.Rows - 1 & "条"
        Me.ProgressBar1.Max = .Rows - 1
        Dim iResult As Integer
        DoEvents
        For i = 1 To .Rows - 1
            sqlstr = "select count(*) from fd_accdef where Caccid='" & .TextMatrix(i, 1) & "'"
            Set rsacc = dbsZJ.OpenRecordset(sqlstr, dbOpenSnapshot)
            If rsacc(0) <> 0 Then
                MsgBox "第" & i & "行数据在账号表中已存在！" & vbCrLf & "请更改后重试保存操作！", vbInformation, "账号升级"
                CheckData = False
                Frame2.Visible = False
                Exit Function
            End If
            Me.ProgressBar1.Value = i
            iResult = i Mod 100
            If iResult = 0 Then
                DoEvents
                Label8.Caption = "已处理" & i & "条"
            End If
        Next
    End With
    CheckData = True
Debug.Print "after sql" & Time
End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
     Dim result As VbMsgBoxResult
    'If credstat.modified Then
    If ((Not tlbTool.Buttons("cmdyulan").Enabled) And tlbTool.Buttons("save").Enabled) Then
        result = MsgBox("您还有数据未保存，是否决定在退出贷款额度程序时保存数据？", vbYesNoCancel, "退出程序")
        Select Case result
         Case vbYes
             If SaveData Then
                Cancel = 0
             Else
                Cancel = 1
                Frame2.Visible = False
                Exit Sub
             End If
        Case vbNo
            Cancel = 0
        Case vbCancel
            Cancel = 1
            Exit Sub
        End Select
   End If
    If con.State = adStateOpen Then
        con.Close
    End If
    Set con = Nothing
    frmQuqeryAcc.m_accUpgrade = 0

End Sub


Private Sub Form_Resize()
    
    ResizeTlb Me
    
    If Me.WindowState <> 1 Then
        Label1.top = tlbTool.Height + 150
        Edit1.top = Label1.top
        cmdDateRef.top = Label1.top
        
        SuperGrid1.top = Label1.top + 300
        If Me.width - Label1.top - Edit1.Height - 2400 > 0 Then
            SuperGrid1.Height = Me.Height - Label1.top - Edit1.Height - 1800
            SuperGrid1.width = Me.width - 200
            
            Label2(0).top = SuperGrid1.top + SuperGrid1.Height + 150
            Edit1.top = Label2(0).top + 250
            Label2(3).top = Edit2.top
            Label2(1).top = Label2(0).top + 250
            Label2(2).top = Label2(1).top + 250
            Label2(3).top = Label2(2).top + 250
            
            Label3.top = Label2(1).top
            Label4.top = Label2(1).top
            Label5.top = Label4.top
            Frame1.top = Label2(1).top - 120
            optWz2(0).top = Frame1.top
            optWz2(1).top = optWz2(0).top + 240
            
            txtbcws.top = Label2(2).top
            
            Edit2.top = Label2(3).top
            
        End If
    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 optWz1_GotFocus(index As Integer)
    If txtSjrq.Enabled Then
        cmdDateRef.Visible = False
    End If
End Sub

Private Sub SuperGrid1_CellDataCheck(RetValue As String, RetState As MsSuperGrid.OpType, ByVal R As Long, ByVal C As Long)
    count_i = count_i + 1
    Debug.Print errorNUM & count_i & error_Edit & "cell_data_check)"
    Screen.MousePointer = vbHourglass
    If errorNUm1 = 0 Then
        Call checkDup(R, C)
        'errorNUm1 = 1
    Else
        errorNUm1 = 0
    End If
    Screen.MousePointer = vbDefault
    If error_Edit Then
        SuperGrid1.row = R
        SuperGrid1.col = C
        SuperGrid1.SetFocus
    End If
End Sub

Private Sub SuperGrid1_GotFocus()
    If txtSjrq.Enabled Then
        cmdDateRef.Visible = False
    End If
End Sub

Private Sub SuperGrid1_LostFocus()
    count_i = count_i + 1
    Debug.Print errorNUM & count_i & error_Edit & "lostfocus"
    SuperGrid1.ProtectUnload
    Debug.Print errorNUM & error_Edit & "lostfocus after protextunload"
    If error_Edit Then
        If errorNUM = 0 Then
            MsgBox "请先改正输入错误！", vbInformation, "账号升级"
            errorNUM = 1
            SuperGrid1.row = selrow
            SuperGrid1.col = selcol
            SuperGrid1.SetFocus
        Else
            errorNUM = 0
        End If
    End If
End Sub

Private Sub SuperGrid1_RowColChange()
    If Not tlbTool.Buttons("cmdyulan").Enabled Then
        If SuperGrid1.col = 1 Then
            SuperGrid1.ReadOnly = False
        Else
            SuperGrid1.ReadOnly = True
        End If
    Else
        SuperGrid1.ReadOnly = True
    End If
    count_i = count_i + 1
    Debug.Print errorNUM & count_i & error_Edit & "errornum rowcolchange"
    If error_Edit Then
        If errorNUM = 0 And errorNUm1 = 0 Then
            MsgBox "请先改正输入错误！", vbInformation, "账号升级"
            errorNUM = 1
            SuperGrid1.row = selrow
            SuperGrid1.col = selcol
            SuperGrid1.SetFocus
        Else
            errorNUM = 0
        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) = "升级日期"
    
    AttrValue(0) = CStr(Format(txtSjrq.Text, "YYYY-MM-DD"))
    prnxml.InsertHeadNodes "表头", "字段", AttrName, AttrValue
    
    '插入表体头数据
    ReDim AttrName(6, 1)
    ReDim AttrValue(6)
    For i = 0 To 6
        AttrName(i, 0) = "单元"
    Next
    AttrValue(0) = "新账户号"
    AttrValue(1) = "旧账户号"
    AttrValue(2) = "账户名称"
    AttrValue(3) = "单位名称"
    AttrValue(4) = "开户日期"
    AttrValue(5) = "开户银行"
    AttrValue(6) = "币别"
    prnxml.InsertBodyNodes "表体", "表体头", AttrName, AttrValue
    For i = 0 To 6
        AttrValue(i) = ""
    Next
    
    '插入表体行数据
     With SuperGrid1
        For i = 1 To .Rows - 1
            AttrValue(0) = .TextMatrix(i, 1)
            AttrValue(1) = .TextMatrix(i, 0)
            AttrValue(2) = .TextMatrix(i, 2)
            AttrValue(3) = .TextMatrix(i, 3)
            AttrValue(4) = .TextMatrix(i, 4)
            AttrValue(5) = .TextMatrix(i, 5)
            AttrValue(6) = .TextMatrix(i, 6)
            prnxml.InsertBodyNodes "表体", "表体行", AttrName, AttrValue
        Next
    End With
    '保存数据文件
    prnxml.saveFile "taccUpData.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 & "\taccUpdata.xml"
    sStyle = App.Path & "\taccUpStyle.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