frmaccupgrade.frm

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

Private sqlstr As String
Public sqlwhere As String
Private AccID() As String
Private modified As Boolean
Dim xmlInit As Boolean
Dim selrow As Long
Dim selcol As Long
Dim error_Edit As Boolean
Dim errorNUM As Integer
Dim errorNUm1 As Integer
Dim count_i As Long


Private Sub cmdDateRef_Click()
    Dim str As Date
    Dim Calendar As New CalendarAPP.ICaleCom
    Calendar.Caption = "升级日期"
    Calendar.DateDivideChar = "-"
    txtSjrq.Text = Calendar.Calendar(txtSjrq.hWnd)
'    str = Calendar.Calendar(Edit1.hWnd)
'    Edit1.Text = CDate(str)
    Set Calendar = Nothing
End Sub

Private Sub yulanProc()
    Dim qyrq As String
    Dim rsacc As New UfRecordset
    
    '取系统启用日期
    sqlstr = "select option1 from fd_option "
    Set rsacc = dbsZJ.OpenRecordset(sqlstr, dbOpenDynamic)
    If Not (rsacc.EOF Or rsacc.BOF) Then
        qyrq = DateCheck(rsacc(0))
    Else
        qyrq = ""
    End If
    rsacc.oClose
    
    '检查升级日期的合法性
    If txtSjrq.Text = "" Then
        MsgBox "升级日期不能为空", vbInformation, "账号升级"
        Exit Sub
    ElseIf DateCheck(Trim(txtSjrq.Text)) = "" Then
        MsgBox "升级日期输入错误", vbInformation, "账号升级"
        Exit Sub
    ElseIf qyrq <> "" Then
        If Trim(txtSjrq.Text) < qyrq Then
            MsgBox "升级日期不能小于系统启用日期", vbInformation, "账号升级"
            Exit Sub
        End If
    End If
    If Trim(txtSjrq.Text) > zjLogInfo.curDate Then
            MsgBox "升级日期不能大于系统登录日期", vbInformation, "账号升级"
            Exit Sub
    End If
    '取已有升级信息的最大调整日期
    sqlstr = "select max(upgrade_date) from fd_accUpgrade "
    If sqlwhere <> "" Then
        sqlstr = sqlstr & " where fd_accupgrade.accdef_id in (select accdef_id from fd_accdef inner join fd_accunit on fd_accdef.cunitcode=fd_accunit.cunitcode "
        sqlstr = sqlstr & " where " & sqlwhere & ")"
    End If
    Set rsacc = dbsZJ.OpenRecordset(sqlstr, dbOpenDynamic)
    If Not (rsacc.EOF Or rsacc.BOF) Then
        qyrq = IIf(IsNull(rsacc(0)), "", rsacc(0))
        qyrq = DateCheck(qyrq)
    Else
        qyrq = ""
    End If
    rsacc.oClose
    If qyrq <> "" Then
        If CDate(Trim(txtSjrq.Text)) <= CDate(qyrq) Then
            MsgBox "升级日期不能小于上次账号升级日期", vbInformation, "账号升级"
            Exit Sub
        End If
    End If
    
    '检查补充位置的合法性
    If Edit1.Text = "" Then
        MsgBox "补充位置不能为空", vbInformation, "账号升级"
        GoTo Error0
    End If
    If CDbl(Edit1.Text) <= 0 Then
        MsgBox "补充位置必须大于0", vbInformation, "账户号升级"
        GoTo Error0
    End If
    
    '检查补充位数的合法性
    If txtbcws.Text = "" Then
        MsgBox "补充位数不能为空", vbInformation, "账号升级"
        GoTo Error0
    End If
    If sqlwhere <> "" Then
        sqlstr = "select max(len(Caccid)) from fd_accdef  inner join fd_accunit on fd_accdef.cunitcode=fd_accunit.cunitcode Where " & sqlwhere
    Else
        sqlstr = "select max(len(Caccid)) from fd_accdef  inner join fd_accunit on fd_accdef.cunitcode=fd_accunit.cunitcode " & sqlwhere
    End If
    Set rsacc = dbsZJ.OpenRecordset(sqlstr, dbOpenSnapshot)
    If rsacc(0) + CInt(txtbcws.Text) > 50 Then
        MsgBox "补充位数必须小于" & 50 - rsacc(0), vbInformation, "账户号升级"
        GoTo Error0
    End If
    
    '检查补充字符的合法性
    If Edit2.Text = "" Then
        MsgBox "补充字符不能为空", vbInformation, "账号升级"
        GoTo Error0
    End If
    If InStr(1, Trim(Edit2.Text), " ") <> 0 Then
        MsgBox "补充字符中不能含有空格", vbInformation, "账户号升级"
        GoTo Error0
    End If
    If Len(Trim(Edit2.Text)) <> CInt(txtbcws.Text) Then
        MsgBox "补充字符串长度与补充位数不符", vbInformation, "账户号升级"
        GoTo Error0
    End If
    
    '置修改状态位
    modified = True
    
    '账号升级
    Call cons_new_code
    
Error0:
    If rsacc.State = adStateOpen Then
        rsacc.oClose
    End If
    Set rsacc = Nothing
End Sub

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

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

Private Sub Form_Load()
    loadstatic
    SetTBStyle Me
    error_Edit = False
    con.ConnectionString = zjLogInfo.UfDbName
    con.Open
    count_i = 0
    'set toobool statues
    With tlbTool
        .Buttons("print").Enabled = True
        .Buttons("preview").Enabled = True
        .Buttons("output").Enabled = True
        .Buttons("search").Enabled = True
        .Buttons("cmdyulan").Enabled = True
        .Buttons("cancel").Enabled = False
        .Buttons("save").Enabled = False
    End With
    
    'set commondbutton statues
'    cmdYuLan.Enabled = True
    
    optWz1(0).Value = True
    optWz2(0).Value = True
    
    sqlwhere = ""
    
    Call fillGrid(False)
    ocxCTBtool.RefreshEnable
End Sub

'load data to grid
Private Sub fillGrid(Save As Boolean)
    Dim rsacc As New UfRecordset
    Dim i As Long
    
    'load data to grid
    On Error GoTo Error0
    If Not Save Then
        sqlstr = "SELECT dbo.FD_AccDef.accdef_id, dbo.FD_AccUnit.cUnitName, dbo.FD_AccDef.cAccBank,"
        sqlstr = sqlstr & "dbo.FD_AccDef.cAccID,dbo.FD_AccDef.cAccName, dbo.FD_AccDef.dOpenDate,dbo.FD_AccDef.cexch_name"
        sqlstr = sqlstr & " FROM dbo.FD_AccDef INNER JOIN"
        sqlstr = sqlstr & " dbo.FD_AccUnit ON dbo.FD_AccDef.accunit_id = dbo.FD_AccUnit.accunit_id"
    Else
        sqlstr = "SELECT dbo.fd_accUpgrade.accdef_id ,dbo.fd_accUpgrade.old_Caccid As cAccid, dbo.fd_accUpgrade.new_Caccid,dbo.FD_AccDef.cAccName, dbo.FD_AccDef.cexch_name, dbo.FD_AccUnit.cUnitName,dbo.FD_AccDef.dOpenDate , dbo.FD_AccDef.cAccBank"
        sqlstr = sqlstr & " FROM dbo.FD_AccDef INNER JOIN dbo.FD_AccUnit ON dbo.FD_AccDef.accunit_id = dbo.FD_AccUnit.accunit_id INNER JOIN dbo.fd_accUpgrade ON dbo.FD_AccDef.accdef_id = dbo.fd_accUpgrade.accdef_id "
    End If
    sqlstr = sqlstr & " where "
    If Not (sqlwhere = "") Then
        sqlstr = sqlstr & sqlwhere & " and "
    End If
    If Save Then
        sqlstr = sqlstr & "fd_accupgrade.upgrade_date='" & txtSjrq.Text & "' "
        sqlstr = sqlstr & " order by fd_accupgrade.new_caccid"
    Else
        sqlstr = sqlstr & " 1=1 order by len(caccid),caccid"
    End If
    Set rsacc = dbsZJ.OpenRecordset(sqlstr, dbOpenSnapshot)
    If rsacc.RecordCount = 0 Then GoTo Error0
    SuperGrid1.Rows = rsacc.RecordCount + 1
    ReDim AccID(rsacc.RecordCount - 1)
    i = 1
    rsacc.MoveFirst
    While Not (rsacc.EOF Or rsacc.BOF)
        With SuperGrid1
            .TextMatrix(i, 0) = IIf(IsNull(rsacc![cAccId]), "", rsacc![cAccId])
            If Not Save Then
                .TextMatrix(i, 1) = ""
            Else
                .TextMatrix(i, 1) = IIf(IsNull(rsacc![new_caccid]), "", rsacc![new_caccid])
            End If
            .TextMatrix(i, 2) = IIf(IsNull(rsacc![cAccName]), "", rsacc![cAccName])
            .TextMatrix(i, 3) = IIf(IsNull(rsacc![cunitName]), "", rsacc![cunitName])
            .TextMatrix(i, 4) = IIf(IsNull(rsacc![dOpenDate]), "", rsacc![dOpenDate])
            .TextMatrix(i, 5) = IIf(IsNull(rsacc![cAccbank]), "", rsacc![cAccbank])
            .TextMatrix(i, 6) = IIf(IsNull(rsacc![cexch_name]), "", rsacc![cexch_name])
        End With
        AccID(i - 1) = rsacc![accdef_id]
        i = i + 1
        rsacc.MoveNext
    Wend
    rsacc.oClose
    With tlbTool
        .Buttons("print").Enabled = True
        .Buttons("preview").Enabled = True
        .Buttons("output").Enabled = True
        .Buttons("search").Enabled = True
        .Buttons("cmdyulan").Enabled = True
        .Buttons("cancel").Enabled = False
        .Buttons("save").Enabled = False
    End With
    Exit Sub
Error0:
'    If rsacc.State = adStateOpen Then
'        rsacc.oClose
'    End If
    SuperGrid1.clear
    SuperGrid1.Rows = 2
    initGrid
    'set toobool statues
    With tlbTool
        .Buttons("print").Enabled = False
        .Buttons("preview").Enabled = False
        .Buttons("output").Enabled = False
        .Buttons("search").Enabled = True
        .Buttons("cmdyulan").Enabled = False
        .Buttons("cancel").Enabled = False
        .Buttons("save").Enabled = False
    End With
    
    'set commondbutton statues
'    cmdYuLan.Enabled = False

End Sub

'construct new account code
Private Sub cons_new_code()
    Dim left As Boolean
    Dim before As Boolean
    Dim i As Long
    
    If optWz1(0).Value Then
        left = True
    Else
        left = False
    End If
    If optWz2(0).Value Then
        before = True
    Else
        before = False
    End If
    With SuperGrid1
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 1) <> "" Then
                .TextMatrix(i, 0) = .TextMatrix(i, 1)
                .TextMatrix(i, 1) = ""
            End If
        Next
        If left Then
            If before Then
                For i = 1 To .Rows - 1
                    If Edit1.Text <= Len(.TextMatrix(i, 0)) Then
                        .TextMatrix(i, 1) = mID(.TextMatrix(i, 0), 1, Edit1.Text - 1) & Trim(Edit2.Text) & mID(.TextMatrix(i, 0), Edit1.Text)
                    Else
                        .TextMatrix(i, 1) = .TextMatrix(i, 0) & Trim(Edit2.Text)
                    End If
                Next
            Else
                For i = 1 To .Rows - 1
                    If Edit1.Text < Len(.TextMatrix(i, 0)) Then
                        .TextMatrix(i, 1) = mID(.TextMatrix(i, 0), 1, Edit1.Text) & Trim(Edit2.Text) & mID(.TextMatrix(i, 0), Edit1.Text + 1)
                    Else
                        .TextMatrix(i, 1) = .TextMatrix(i, 0) & Trim(Edit2.Text)
                    End If
                Next
            End If
        Else
            If before Then
                For i = 1 To .Rows - 1
                    If Edit1.Text < Len(.TextMatrix(i, 0)) Then
                        .TextMatrix(i, 1) = mID(.TextMatrix(i, 0), 1, Len(CStr(.TextMatrix(i, 0))) - CInt(Edit1.Text)) & Trim(Edit2.Text) & right(.TextMatrix(i, 0), Edit1.Text)
                    Else
                        .TextMatrix(i, 1) = Trim(Edit2.Text) & .TextMatrix(i, 0)
                    End If
                Next
            Else
                For i = 1 To .Rows - 1
                    If Edit1.Text <= Len(.TextMatrix(i, 0)) Then
                        .TextMatrix(i, 1) = mID(.TextMatrix(i, 0), 1, Len(.TextMatrix(i, 0)) - Edit1.Text + 1) & Trim(Edit2.Text) & right(.TextMatrix(i, 0), Edit1.Text - 1)
                    Else
                        .TextMatrix(i, 1) = Trim(Edit2.Text) & .TextMatrix(i, 0)
                    End If
                Next
            End If
        End If
    End With
    'cmdYuLan.Enabled = False
    With tlbTool
        .Buttons("cmdyulan").Enabled = False
        .Buttons("print").Enabled = False
        .Buttons("preview").Enabled = False
        .Buttons("output").Enabled = False
        .Buttons("search").Enabled = False
        .Buttons("cancel").Enabled = True
        .Buttons("save").Enabled = True
    End With
End Sub

Private Sub CancelProc()
    Dim i As Integer
    'cmdYuLan.Enabled = True
    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
    With SuperGrid1
        For i = 1 To .Rows - 1
            .TextMatrix(i, 1) = ""
        Next
    .ReadOnly = True
    End With
End Sub

Private Function SaveData() As Boolean
    Dim i As Long
    Err.clear
    On Error Resume Next
    i = UBound(AccID)
    If Err.Number <> 0 Then
        MsgBox "保存失败", vbInformation, "账号升级"
        SaveData = False
        Exit Function
    End If
    
    Dim con As New ADODB.Connection
    On Error GoTo Error0
    con.ConnectionString = zjLogInfo.UfDbName
    con.Open
    Debug.Print "before check" & Time
    If CheckData() Then
        Debug.Print "after check" & Time
        On Error GoTo Error1
        Label6.Caption = "正在保存数据！请等待......"
        Label8.Caption = "已处理0条"
        Me.ProgressBar1.Max = SuperGrid1.Rows - 1
        DoEvents
        Dim iResult As Integer
        con.BeginTrans
        With SuperGrid1
            For i = .Rows - 2 To 0 Step -1
                sqlstr = "insert into fd_accUpgrade (accdef_id,old_Caccid,new_Caccid,upgrade_date) values('"
                sqlstr = sqlstr & AccID(i) & " ','" & .TextMatrix(i + 1, 0) & "','" & .TextMatrix(i + 1, 1) & "','" & txtSjrq.Text & "')"
                con.Execute sqlstr
                '更新fd_accdef , fd_accset(accdef_id, cAccId)
                sqlstr = "Update fd_accdef set Caccid='" & .TextMatrix(i + 1, 1) & "' where Caccid='" & .TextMatrix(i + 1, 0) & "' and accdef_id='" & AccID(i) & "'"
                con.Execute sqlstr
                sqlstr = "Update fd_accset set Caccid='" & .TextMatrix(i + 1, 1) & "' where Caccid='" & .TextMatrix(i + 1, 0) & "' and accdef_id='" & AccID(i) & "'"
                con.Execute sqlstr
                '更新fd_accsum (cAccId), fd_Vouch(cacc1_id, cacc2_id)
                sqlstr = "update fd_accsum set Caccid='" & .TextMatrix(i + 1, 1) & "' where Caccid='" & .TextMatrix(i + 1, 0) & "'"
                con.Execute sqlstr