customerinitdetail1.frm

金算盘软件代码

End Sub

'得到账套启用日期
Private Sub GetStartDate()
    Dim strSql As String
    Dim recTemp As rdoResultset
    
    strSql = "Select strStartDate From Business"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    mstrStartDate = recTemp("strStartDate")
    strSql = "SELECT * FROM AccountPeriod WHERE lngCloseID>0 AND strEndDate>='" & mstrStartDate & "'"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.RowCount > 0 Then
        mblnIsClosed = True
        Exit Sub
    Else
        mblnIsClosed = False
    End If
    Set recTemp = gclsBase.BaseDB.OpenResultset("Select strStartDate From AccountPeriod Where strStartdate<='" _
        & mstrStartDate & "' And strEndDate>='" & mstrStartDate & "'", rdOpenStatic)
    If recTemp.RowCount = 1 Then
        mstrStartDate = Format(CDate(recTemp("strStartDate")), "YYYY-MM-DD")
    End If
    recTemp.Close
    strSql = "Select Min(strStartDate) As strBeginDate From AccountPeriod"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    mstrBeginDate = recTemp("strBeginDate")
    recTemp.Close
End Sub

'得到科目性质
Private Sub GetAccountNature(ByVal lngAccountID As Long)
    Dim strSql As String
    Dim recTemp As rdoResultset
    
    strSql = "Select lngAccountNatureID,blnIsMultCurrency , blnIsAllCurrency" _
        & ",intDirection From Account Where lngAccountID=" & lngAccountID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTemp.EOF Then
        mudtAccount.Nature = recTemp("lngAccountNatureID")
        mudtAccount.IsMutCur = recTemp("blnIsMultCurrency")
        mudtAccount.IsAllCur = recTemp("blnIsAllCurrency")
        mudtAccount.Direction = recTemp("intDirection")
    End If
    recTemp.Close
End Sub

'设置参照
Private Sub SetListText(ByVal Index As Integer)
    Dim strSql As String
    
    Select Case Index
        Case 1  '凭证类型
            strSql = "Select lngVoucherTypeID,strVoucherTypeCode,strVoucherTypeName From VoucherType " _
                & "Where blnIsInActive=0 Order By strVoucherTypeCode"
        Case 3  '摘要
            strSql = "Select lngRemarkID,strRemarkCode,strRemarkName From Remark Order By strRemarkCode"
        Case 4  '付款条件
            strSql = "Select lngTermID,strTermCode,strTermName From Term Where blnIsInActive=0 Order By strTermCode"
        Case 7  '部门
            strSql = "Select lngDepartmentID,strDepartmentCode,strDepartmentName From Department Where blnIsInActive=0 Order By strDepartmentCode"
        Case 8  '职员
            strSql = "Select lngEmployeeID,strEmployeeCode,strEmployeeName From Employee Where blnIsInActive=0 Order By strEmployeeCode"
        Case 9  '统计
            strSql = "Select lngClassID,strClassCode,strClassName From Class1 Where blnIsInActive=0 Order By strClassCode"
        Case 10  '项目
            strSql = "Select lngClassID,strClassCode,strClassName From Class2 Where blnIsInActive=0 Order By strClassCode"
        Case 30  '科目
            strSql = "Select lngAccountID,strAccountCode,strAccountName From Account Where blnIsDetail=1" _
                & " And blnIsInActive=0 And lngAccountNatureID In (3,4)  Order By strAccountCode"
        Case 31  '币种
            If mudtAccount.IsAllCur Then
                strSql = "Select lngCurrencyID,strCurrencyCode,strCurrencyName From Currencys"
            Else
                If mudtAccount.IsMutCur Then
                    strSql = "Select Currencys.lngCurrencyID,strCurrencyCode,strCurrencyName From AccountCurrency " _
                        & ",Currencys Where AccountCurrency.lngCurrencyID=Currencys.lngCurrencyID" _
                        & " And AccountCurrency.lngAccountID=" & mudtAccount.ID
                Else
                    strSql = "Select lngCurrencyID,strCurrencyCode,strCurrencyName From Currencys Where lngCurrencyID=1"
                End If
            End If
        Case 32  '单位
            strSql = "Select lngCustomerID,strCustomerCode,strCustomerName From Customer Where blnIsInActive=0 Order By strCustomerCode"
    End Select
    Select Case Index
        Case 1, 3, 4, 7, 8, 9, 10
            With lstCustomerInitdetail(3)
                .ClearRefer
                .SeekCol = "1,2,3"
                Set .Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                .AddRefer "<新增>", 0, 1  '设置固定选项
                .AddRefer "<修改>", 1, 1
                .AddRefer "<删除>", 2, 1
            End With
        Case 30, 32
            With lstCustomerInitdetail(Index - 30)
                .ClearRefer
                .SeekCol = "1,2,3"
                Set .Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                .AddRefer "<新增>", 0, 1  '设置固定选项
                .AddRefer "<修改>", 1, 1
                .AddRefer "<删除>", 2, 1
            End With
        Case 31
            With lstCustomerInitdetail(Index - 30)
                .ClearRefer
                .SeekCol = "1,2,3"
                Set .Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If mudtAccount.IsAllCur Or mudtAccount.IsMutCur Then
                    .AddRefer "<新增>", 0, 1  '设置固定选项
                    .AddRefer "<修改>", 1, 1
                    .AddRefer "<删除>", 2, 1
                End If
            End With
    End Select
End Sub

'处理回车键
Private Sub ReturnProc()
    Dim intCount As Integer
    Dim intVisibleRow As Integer
    
    If InputFinish() Then
        With msgCustomerInitDetail
            For intCount = mintCol + 1 To .Cols - 1
                If .ColWidth(intCount) > 0 Then Exit For
            Next
            If intCount <= .Cols - 1 Then
                .col = intCount
                .Row = mlngRow
                FlexInput .Row, .col
                mblnisReturn = True
            Else
                If mlngRow < .Rows - 1 Then
                    .Row = mlngRow + 1
                    .col = 0
                    intVisibleRow = GetVisibleRow - 3
                    If .Row - intVisibleRow > 0 Then
                       .TopRow = IIf(.Rows - intVisibleRow <= .Rows - 1, .Rows - intVisibleRow, .Rows - 1)
                    End If
                    FlexInput .Row, .col
                    mblnisReturn = True
                End If
            End If
        End With
    End If
End Sub

Private Function GetVisibleRow()
  Dim intRow As Integer
  
   With msgCustomerInitDetail
      For intRow = .TopRow To .Rows - 1
         If Not .RowIsVisible(intRow) Then
            Exit Function
         End If
         GetVisibleRow = GetVisibleRow + 1
      Next intRow
   End With
End Function

'参照新增
Private Sub ListTextAddNew()
    Dim lngID As Long
    Dim lngOldID As Long
    
    With lstCustomerInitdetail(3)
        lngOldID = .ID
        Select Case mintCol
            Case 1
                lngID = Card.AddCard(Message.msgVoucherType)
            Case 3
                lngID = Card.AddCard(Message.msgRemark)
            Case 4
                lngID = Card.AddCard(Message.msgTerm)
            Case 7
                lngID = Card.AddCard(Message.msgDepartment)
            Case 8
                lngID = Card.AddCard(Message.msgEmployee)
            Case 9
                lngID = Card.AddCard(Message.msgClass)
            Case 10
                lngID = Card.AddCard(Message.msgClass2)
        End Select
        If lngID > 0 Then
            SetListText mintCol
            mblnIsAddNew = True
            .SeekId lngID
        Else
            .SeekId lngOldID
        End If
    End With
End Sub

'参照删除
Private Sub ListTextDelete()
    Dim lngID As Long
    Dim blnSuccess As Boolean
    
    With lstCustomerInitdetail(3)
        lngID = .ID
        Select Case mintCol
            Case 1
                If IsUsed(lngID, 16) Then
                    ShowMsg Me.hwnd, "凭证类型“" & .Text & "”已经使用，不能删除！", vbInformation, Me.Caption
                Else
                    blnSuccess = Card.DelCard(Message.msgVoucherType, lngID)
                End If
            Case 3
                blnSuccess = Card.DelCard(Message.msgRemark, lngID)
            Case 4
                If IsUsed(lngID, 17) Then
                    ShowMsg Me.hwnd, "付款条件“" & .Text & "”已经使用，不能删除！", vbInformation, Me.Caption
                Else
                    blnSuccess = Card.DelCard(Message.msgTerm, lngID)
                End If
            Case 7
                If IsUsed(lngID, 18) Then
                    ShowMsg Me.hwnd, "部门“" & .Text & "”已经使用，不能删除！", vbInformation, Me.Caption
                Else
                    blnSuccess = Card.DelCard(Message.msgDepartment, lngID)
                End If
            Case 8
                If IsUsed(lngID, 19) Then
                    ShowMsg Me.hwnd, "职员“" & .Text & "”已经使用，不能删除！", vbInformation, Me.Caption
                Else
                    blnSuccess = Card.DelCard(Message.msgEmployee, lngID)
                End If
            Case 9
                If IsUsed(lngID, 20) Then
                    ShowMsg Me.hwnd, "统计“" & .Text & "”已经使用，不能删除！", vbInformation, Me.Caption
                Else
                    blnSuccess = Card.DelCard(Message.msgClass, lngID)
                End If
            Case 10
                If IsUsed(lngID, 21) Then
                    ShowMsg Me.hwnd, "项目“" & .Text & "”已经使用，不能删除！", vbInformation, Me.Caption
                Else
                    blnSuccess = Card.DelCard(Message.msgClass2, lngID)
                End If
        End Select
        If blnSuccess Then
            SetListText mintCol
            If mintCol = 31 And Not (mudtAccount.IsAllCur Or mudtAccount.IsMutCur) Then
                If .Referrows > 0 Then
                    .ReferRow = 0
                End If
            Else
                If .Referrows > 3 Then
                    .ReferRow = 4
                End If
            End If
        End If
    End With
End Sub

'参照编辑
Private Sub ListTextEdit()
    Dim lngID As Long
    
    With lstCustomerInitdetail(3)
        lngID = .ID
        Select Case mintCol
            Case 1
                Card.EditCard Message.msgVoucherType, lngID
            Case 3
                Card.EditCard Message.msgRemark, lngID
            Case 4
                Card.EditCard Message.msgTerm, lngID
            Case 7
                Card.EditCard Message.msgDepartment, lngID
            Case 8
                Card.EditCard Message.msgEmployee, lngID
            Case 9
                Card.EditCard Message.msgClass, lngID
            Case 10
                Card.EditCard Message.msgClass2, lngID
        End Select
        SetListText mintCol
        .SeekId lngID
        msgCustomerInitDetail.TextMatrix(mlngRow, mintCol) = .Text
    End With
End Sub

'设置初始化
Private Sub SetInitDetail(ByVal CurrencyID As Long)
    Dim intCount As Integer
    Dim intColumn(7) As Integer
    
    With msgCustomerInitDetail
        For intCount = 1 To mclsListSet.Columns
            .ColWidth(intCount - 1) = mclsListSet.ColumnWidth(intCount)
        Next
    End With
    
    '设置科目参照
    SetListText 30
    lstCustomerInitdetail(0).ReferRow = 4
    GetAccountNature mudtAccount.ID
    '设置币种参照
    SetListText 31
    mlngCurrencyID = CurrencyID
    If mudtAccount.IsAllCur Or mudtAccount.IsMutCur Then
        lstCustomerInitdetail(1).ReferRow = 4
        If CurrencyID <> 0 Then
           lstCustomerInitdetail(1).SeekId CurrencyID
        End If
    Else
        lstCustomerInitdetail(1).ReferRow = 0
    End If
    '设置单位参照
    SetListText 32
    lstCustomerInitdetail(2).SeekId mlngCustomerID
    GetDetail
    For intCount = 1 To 7
        intColumn(intCount) = GetSetting(App.title, "CusInit1", "Col" & intCount, 0)
    Next intCount
    SetDefCol intColumn
End Sub

'设置MS FELEXGRID
Private Sub SetFlexGrid()
    Dim intCount As Integer, lngRowCount As Long
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim blnIsAssistant(4) As Boolean
    Dim intColumn(7) As Integer
    
    With msgCustomerInitDetail
        .AddItem "", 1
        .RowHeight(1) = 0
        For intCount = 15 To 22