frmaccountcopycard.frm

金算盘软件代码

    With recAccount
        Do Until .EOF
            strAStr = strAStr & recAccount("strAccountCode") & ","
            If stringCount(recAccount("strAccountCode"), "-") <= intLevel Then
                lngAcnID = !lngAccountID
                strAccount = ""
                strAccount = mstrDCode & GetDetailCode(!strAccountCode)
                strAccount = strAccount & Chr(9) & !strAccountName
                strAccount = strAccount & Chr(9) & mlngAccountTypeID
                strAccount = strAccount & Chr(9) & !intLevel
                strAccount = strAccount & Chr(9) & mintDirection
                strAccount = strAccount & Chr(9) & Trim(!strQuantityUnit)
                strAccount = strAccount & Chr(9) & !blnIsAllCurrency
                strAccount = strAccount & Chr(9) & !strFullName
                strAccount = strAccount & Chr(9) & !blnIsDetail
                If chkAccountFlags(3).Value = Checked Then
                    strAccount = strAccount & Chr(9) & !lngAccountNatureID
                Else
                    strAccount = strAccount & Chr(9) & mlngAccountNatureID
                End If
                If chkAccountFlags(0).Value = Checked Then
                    strAccount = strAccount & Chr(9) & !blnIsMultCurrency
                Else
                    strAccount = strAccount & Chr(9) & "0"
                End If
                If chkAccountFlags(1).Value = Checked Then
                    strAccount = strAccount & Chr(9) & !blnIsQuantity
                Else
                    strAccount = strAccount & Chr(9) & "0"
                End If
                If chkAccountFlags(2).Value = Checked Then
                    strAccount = strAccount & Chr(9) & !blnIsCustomer
                    strAccount = strAccount & Chr(9) & !blnIsDepartment
                    strAccount = strAccount & Chr(9) & !blnIsEmployee
                    strAccount = strAccount & Chr(9) & !blnIsClass1
                    strAccount = strAccount & Chr(9) & !blnIsClass2
                Else
                    If !lngAccountNatureID = 3 Or !lngAccountNatureID = 4 Then
                        strAccount = strAccount & Chr(9) & !blnIsCustomer
                    Else
                        strAccount = strAccount & Chr(9) & "0"
                    End If
                    strAccount = strAccount & Chr(9) & "0"
                    strAccount = strAccount & Chr(9) & "0"
                    strAccount = strAccount & Chr(9) & "0"
                    strAccount = strAccount & Chr(9) & "0"
                End If
                strAccount = strAccount & Chr(9) & "0"
                strAccount = strAccount & Chr(9) & !blnIsCash
                If chkAccountFlags(0).Value = Checked Then
                    strAccount = strAccount & Chr(9) & !blnIsCalcExchange
                Else
                    strAccount = strAccount & Chr(9) & 0
                End If
                intR = frmAccountCard.AddAccount(strAccount, , True)
                .Requery
                If intR = 0 Then
    '                .Close
    '                Exit Function
                ElseIf !blnIsMultCurrency = 1 Then
                    If Not CopyAccountCurrency(lngAcnID, StringOut(strAccount, Chr(9))) Then
                        .Close
                        Exit Function
                    End If
                End If
                Do While InStr(strAStr, "," & recAccount("strAccountCode") & ",") > 0
                    .MoveNext
                    If .EOF Then Exit Do
                Loop
            Else
                .MoveNext
            End If
        Loop
        .Close
    End With
    CopyAccount = True
    gclsBase.BaseWorkSpace.CommitTrans
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Function CopyAccountCurrency(ByVal lngSID As Long, ByVal strCode As String) As Boolean
    Dim lngDID As Long, recAccount As rdoResultset, strSql As String
    
    CopyAccountCurrency = False
    strSql = "SELECT * FROM Account WHERE strAccountCode='" & strCode & "'"
    Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recAccount.EOF Then
        recAccount.Close
        Exit Function
    Else
        lngDID = recAccount("lngAccountID")
        recAccount.Close
    End If
    
    strSql = "INSERT INTO AccountCurrency SELECT " & lngDID & " lngAccountID" _
        & ",AC.lngCurrencyID FROM AccountCurrency AC WHERE AC.lngAccountID=" & lngSID
    If Not gclsBase.ExecSQL(strSql) Then Exit Function
    CopyAccountCurrency = True
End Function

Private Function GetDetailCode(ByVal strSCode As String) As String
'    Dim strCode As String

'    strCode = strSCode
'    strCode = StringOut(strCode, "-")
    GetDetailCode = Mid(strSCode, Len(mstrSCode) + 1)
End Function

Private Sub cmdOKOrCancel_Click(Index As Integer)
    Select Case Index
        Case 0
            If Me.ActiveControl.Name = "lstAccountSource" Then
                BKKEY lstAccountSource(Me.ActiveControl.Index).hwnd, vbKeyTab
                Exit Sub
            End If
            If AccountIsValid Then
                If CopyAccount Then
                    Unload Me
                Else
                    ShowMsg hwnd, "复制科目失败！", vbExclamation, Caption
                End If
            End If
        Case 1
            Unload Me
    End Select
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOkorCancel(0).Value = True
    End If
End Sub

Private Sub Form_Load()
    Dim edtErrReturn As ErrDealType, b As Byte
    
    On Error GoTo ErrHandle
    
'    SetHelpID Me.hwnd, 30001
    frmAccountList.IsShowCard(2) = True
    '初始化科目标志默认值
    For b = 0 To 3
        chkAccountFlags(b).Value = 1
    Next b
    
    '初始化科目来源和目标默认值
    intListText
    mstrSCode = ""
    mstrDCode = ""
    mstrSourceAccount = ""
    mstrDesAccount = ""
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload MsgForm
         Unload Me
    End If
End Sub

'画方框
Private Sub Form_Paint()
    FrameBox Me.hwnd, 180, 180, 180 + 4335, 180 + 1575
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    frmAccountList.IsShowCard(2) = False
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Function intListText()
    setlistbox lstAccountSource(0), 0, , True
    setlistbox lstAccountSource(1), 0, , True
End Function

'新增
Private Sub lstAccountSource_AddNew(Index As Integer)
    '新增科目
'    Dim lngAccountID(1) As Long
'    lngAccountID(Index) = Card.AddCard(msgAccount)
'    mlngSourceAccountID(Index) = lngAccountID(Index)
'    SettingListBox lstAccountSource(0), 8
'    SettingListBox lstAccountSource(1), 8
'    lstAccountSource(Index).SeekId lngAccountID(Index)
    
End Sub

'选择
Private Sub lstAccountSource_Choose(Index As Integer)
    mlngSourceAccountID(Index) = lstAccountSource(Index).ID
End Sub

'删除
Private Sub lstAccountSource_Delete(Index As Integer)
'    Dim blnisDel As Boolean
'
'    If mlngSourceAccountID(Index) = 0 Then
'       ShowMsg 0, "编码不存在", vbExclamation + MB_TASKMODAL, Me.Caption
'       lstAccountSource(Index).SetFocus
'       Exit Sub
'    End If
'
'    blnisDel = Card.DelCard(Message.msgAccount, mlngSourceAccountID(Index), frmAccountCopyCard.hwnd)
'    If blnisDel = True Then
'       mlngSourceAccountID(Index) = -1
'       SettingListBox lstAccountSource(0), 8
'       SettingListBox lstAccountSource(0), 8
'       lstAccountSource(Index).Text = ""
'       lstAccountSource(Index).SetFocus
'    Else
'       lstAccountSource(Index).SeekId mlngSourceAccountID(Index)
'    End If
'
End Sub

'修改
Private Sub lstAccountSource_Edit(Index As Integer)
    
End Sub

Private Sub lstAccountSource_GotFocus(Index As Integer)
    If Index = 0 Then
        mstrSourceAccount = lstAccountSource(0).Text
    Else
        mstrDesAccount = lstAccountSource(1).Text
    End If
End Sub

Private Sub lstAccountSource_ItemNotExist(Index As Integer)
    If Index = 0 Then
        lstAccountSource(0).Text = mstrSourceAccount
    Else
        lstAccountSource(1).Text = mstrDesAccount
    End If
End Sub

Private Sub lstAccountSource_LostFocus(Index As Integer)
    Dim i As Integer, intL As Integer, recA As rdoResultset, strSql As String
    
    If Index = 1 Then Exit Sub
    cboLevel.Clear
    strSql = "SELECT MAX(intLevel) iV FROM Account WHERE strAccountCode LIKE '" _
        & StringOut(lstAccountSource(0).Text) & "-%'"
    Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not recA.EOF Then
        intL = Format(recA("iV"), "@;0;")
    Else
        intL = 0
    End If
    recA.Close
    
    For i = 2 To intL - 1
        cboLevel.AddItem i & "级"
        cboLevel.ItemData(cboLevel.NewIndex) = i - 1
    Next i
    cboLevel.AddItem "末级"
    cboLevel.ItemData(cboLevel.NewIndex) = i - 1
    cboLevel.Text = "末级"
End Sub