frmaccupgrade.frm

来自「用友软件部分代码」· FRM 代码 · 共 1,541 行 · 第 1/4 页

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