frmlistcompose.frm

金算盘软件代码

Private Sub mclsMainControl_EditNew()
    'Dim frmEdit As frmStripRigOut
    'Me.Enabled = False
    mblnFinish = True
    If mIsShowEdit Then
        theEditForm.ShowANewBill
    Else
        'Set frmEdit = New frmStripRigOut
        theEditForm.ShowANewBill
        mIsShowEdit = True
        'Set frmEdit = Nothing
    End If
    mblnFinish = False
   ' Me.Enabled = True
End Sub

'删除记录
Private Sub mclsMainControl_EditDel()
    Dim lngActivityID As Long
    
    lngActivityID = GetlngActivityID()
          
    If mIsShowEdit Then
        If lngActivityID = theEditForm.getID Then
            cMsgBox "不能删除当前编辑的单据！"
            Exit Sub
        End If
    End If
    
    If Not DeleteCompose(lngActivityID) Then Exit Sub
    
    '从Grid中删除本行
    With grdList
        If .Rows = 2 Then '要删除的行是GRID 的最后一行
            mclsMainControl_ToolRefresh
        Else
            .RemoveItem (.Row)
        End If
    End With
    
End Sub

'作废
Private Sub mclsMainControl_EditInActive()
    Dim strSql As String
    Dim lngActivityID As Long
On Error GoTo TheErr
    
    If grdList.TextMatrix(grdList.Row, 1) = "√" Then Exit Sub
    lngActivityID = GetlngActivityID()
    
        
    If Not DeleteCompose(lngActivityID, True) Then Exit Sub
   
    With grdList
        If chkShowAll.Value = 1 Then
            If .TextMatrix(.Row, 1) = "" Then
                .TextMatrix(.Row, 1) = "√"
            Else
                .TextMatrix(.Row, 1) = ""
            End If
        Else
            .TextMatrix(.Row, 1) = "√"
            .RowHeight(.Row) = 0
            mclsList.SetFlexRow
            chkShowAll.Enabled = True
            frmMain.mnuEditShowAll.Enabled = True
        End If
    End With
    
    'UpdateMenuStatus
    Exit Sub
TheErr:
    cMsgBox "操作失败！"
End Sub

'全部显示/显示未停用记录
Private Sub mclsMainControl_EditShowAll()
    frmMain.mnuEditShowAll.Checked = Not frmMain.mnuEditShowAll.Checked
    
    If frmMain.mnuEditShowAll.Checked Then
        chkShowAll.Value = 1
    Else
        chkShowAll.Value = 0
    End If
End Sub
'栏目设置
Private Sub mclsMainControl_EditColumn()
    Dim strFind As String
    Dim strSort As String
    Dim intCount As Integer
    
    With grdList
        strFind = .TextMatrix(.Row, mclsList.SortCol)
        strSort = cboFindKind.Text
        If mclsList.ListSet.ShowListSet(intViewID) Then
            .Redraw = False
            grdList.Cols = 0
            Set datGrid.Resultset = GetList()
            If Not datGrid.Resultset.EOF Then datGrid.Resultset.MoveLast
            datGrid.Resultset.Close
            mclsList.SetFlexGrid
            UpdateMenuStatus
            '初始化查找复合列表框
            mclsList.InitcboFindKind
            For intCount = 0 To cboFindKind.ListCount - 1
                If cboFindKind.list(intCount) = strSort Then
                    txtfind.Text = strFind
                    Exit For
                End If
            Next intCount
            If chkShowAll.Value = 0 Then mclsList.DoShowAll False
            .Redraw = True
        End If
    End With
End Sub
'筛选
Private Sub mclsMainControl_EditFilter()
    Dim blnFlage As Boolean
   '执行过滤
    If mclsList.ListSet.ListID < 1 Then
        mclsList.ListSet.SaveList
        DefaultWhere intViewID, mclsList.ListSet.ListID
    End If
    Filter.ShowFilter mclsList.ListSet.ListID, 1, , , , , blnFlage
    If Not blnFlage Then Exit Sub
    grdList.Redraw = False
    mclsList.SaveListSet
    mclsList.ListSet.ViewId = intViewID
    grdList.Cols = 0
    Set datGrid.Resultset = GetList()
    If Not datGrid.Resultset.EOF Then datGrid.Resultset.MoveLast
    datGrid.Resultset.Close
    mclsList.SetFlexGrid
    UpdateMenuStatus
    '初始化查找复合列表框
    mclsList.InitcboFindKind
    If chkShowAll.Value = 0 Then mclsList.DoShowAll False
    grdList.Redraw = True
End Sub
'搜索
Private Sub mclsMainControl_EditSearch()
On Error GoTo TheErr
    frmTreeFind.ShowFind
TheErr:
End Sub

'刷新
Private Sub mclsMainControl_ToolRefresh()
    Dim strOldText As String
    Dim strOldSort As String
    
    Me.MousePointer = vbHourglass
    
'    HaveAnyVoid
    
    With grdList
        '保存当前排序列
        strOldSort = cboFindKind.Text
        strOldText = .TextMatrix(.Row, mclsList.SortCol)
        .Redraw = False
        '刷新列表记录
        .Cols = 0
        Set datGrid.Resultset = GetList()
        If Not datGrid.Resultset.EOF Then datGrid.Resultset.MoveLast
        datGrid.Resultset.Close
        mclsList.SetFlexGrid
        '恢复以前排序列
        cboFindKind.Text = strOldSort
        cboFindKind.Text = strOldSort
        .Redraw = False
        If .Rows > 1 Then
            txtfind.Text = strOldText
        End If
        If chkShowAll.Value = 0 Then mclsList.DoShowAll False
        '更新菜单状态
        UpdateMenuStatus
        .Redraw = True
    End With
    Me.MousePointer = vbDefault
End Sub
'打印
Private Sub mclsMainControl_FilePrint()
    Dim myPrintclass As PrintClass
    Set myPrintclass = New PrintClass
    mclsList.ReGetColCaption
    myPrintclass.PrintList gclsBase.BaseDB, mclsList.FlexGrid, 43, Me.Caption & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName '拆卸组装               43
    mclsList.AddReGetColCaption
    Set myPrintclass = Nothing
End Sub
'
' 报表菜单
'
Private Sub MakeListReportMenu()
    Dim intCnt As Integer
  
    With frmMain
        For intCnt = .mnuListReportMenu.Count - 1 To 1 Step -1
            Unload .mnuListReportMenu(intCnt)
        Next
        
        .mnuListReportMenu(0).Caption = "拆卸组装汇总表"
        .mnuListReportMenu(0).Enabled = True
        .mnuListReportMenu(0).Visible = True
        .mnuListReportMenu(0).Checked = False
        
        Load .mnuListReportMenu(1)
        .mnuListReportMenu(1).Caption = "拆卸组装明细表"
        .mnuListReportMenu(1).Enabled = True
        .mnuListReportMenu(1).Visible = True
        .mnuListReportMenu(1).Checked = False
               
    End With
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    Select Case intIndex
    Case 0:
       ' mclsMainControl_Report 0
        'Report.ShowStandardReport 247, 205
    Case 1:
        'mclsMainControl_Report 1
        'Report.ShowStandardReport 248, 206
    End Select

End Sub

Private Sub mclsMainControl_Report(intReportType As Integer)
    Dim mclsPrintclass As PrintClass
    Set mclsPrintclass = New PrintClass
    
    Select Case intReportType
    Case 0:
        
    Case 1:
        
    End Select
End Sub


Public Sub RefreshList(theCurrentID As Long)
    Dim i As Long
    mclsMainControl_ToolRefresh
    
   '将当前行设置到刷新后的ID=theCurrentID的行
    With grdList
        For i = 1 To .Rows - 1
            If CLng(.TextMatrix(i, 0)) = theCurrentID Then
                theEditRow = i
                GotoRow (i)
                Exit For
            End If
        Next i
    End With
 '   Me.ZOrder 1
 '   FrmPayable.SetFocus
End Sub

'告诉列表：编辑窗口已关闭
Public Sub IAmCLosed()
    mIsShowEdit = False
End Sub



'////////////////////////////////////////////////////////////////////////////////////////
'
'                       功能代码实现
'
'////////////////////////////////////////////////////////////////////////////////////////

'删除《拆卸组装表》
'注意：拆卸组装单一次对应两对记录
Private Function DeleteCompose(lngActivityID As Long, Optional blnByVoid As Boolean) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim lngActivityID_2 As Long
    Dim lngActivityTypeID_2 As Long
    Dim strDelOrVoid As String
    On Error GoTo TheErr
    
    '-----------------------------------------
    Dim intYear As Integer '凭证会计年度
    Dim bytPeriod As Byte   '凭证会计期间
    Dim lngReceiptTypeID As Long
    Dim strReceiptNo As String
    Dim lngReceiptNo As Long
    '------------------------------------------
    
    If blnByVoid Then
        strDelOrVoid = "作废！"
    Else
        strDelOrVoid = "删除！"
    End If
    
    If Not GetItemStatus(lngActivityID) Then Exit Function
    If Not blnChange Then
        cMsgBox "不能" & Left(strDelOrVoid, 2) & "由他人制作的单据！"
        Exit Function
    End If
    
    If blnIsVouchered Then
        cMsgBox "本张商品拆卸组装单已生成记帐凭证，不能" & strDelOrVoid
        Exit Function
    End If
        
    If blnByVoid Then
        If ShowMsg(Me.hwnd, "本张拆卸组装单作废后将不能取消作废，您确实要作废吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
    Else
        If ShowMsg(Me.hwnd, "您确实要删除本张商品拆卸组装单吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
    End If
   
    '查找“组装”对应的“组装出库” 或 “拆卸”对应的“拆卸入库”
    strSql = "SELECT ItemActivity.lngActivityID,ItemActivity.lngActivityTypeID FROM ItemActivity,ItemActivity ItemActivity_1 WHERE (ItemActivity.lngReceiptNO = ItemActivity_1.lngReceiptNO) AND (ItemActivity.strReceiptNO = ItemActivity_1.strReceiptNO) AND (ItemActivity.lngReceiptTypeID = ItemActivity_1.lngReceiptTypeID) and (((ItemActivity_1.lngActivityID)=" & lngActivityID & ") AND (ItemActivity.lngActivityTypeID In (31,32)))"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then
        cMsgBox "删除拆卸组装表失败！"
        Exit Function
    End If
    lngActivityID_2 = recTemp(0)
    lngActivityTypeID_2 = recTemp(0)
    Set recTemp = Nothing

    strSql = "SELECT * From ItemActivity WHERE (lngActivityID)=" & lngActivityID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.EOF Then
        DeleteCompose = True
        Set recTemp = Nothing
        Exit Function
    End If
    '判断单据已否已作废
'    blnVoid = recTemp!blnIsVoid
    '-------------------------------------------------------------------
    intYear = gclsBase.FYearOfDate(C2Date(recTemp!strDate))
    bytPeriod = gclsBase.PeriodOfDate(C2Date(recTemp!strDate))
    lngReceiptTypeID = recTemp!lngReceiptTypeID
    strReceiptNo = recTemp!strReceiptNo
    lngReceiptNo = recTemp!lngReceiptNo
    '--------------------------------------------------------------------
    recTemp.Close
    Set recTemp = Nothing

    gclsBase.BaseWorkSpace.BeginTrans
    
    '1）单据是作废单据，不执行c
    If Not blnIsVoid Then
        If DeleteRelation(lngActivityID, lngActivityTypeID) <> 1 Then GoTo DeleteErr   '删除关系(删除采购发票与受托结算单时须标记对应商品入库单及受托入库单)
        If ChangeAllItem_from_Activity("D", lngActivityID) = False Then GoTo DeleteErr
'        If ChangeAllAccount_from_Activity("D", lngActivityID) = False Then GoTo DeleteErr
        If ModifyItemTable(lngActivityID, False) = False Then GoTo DeleteErr  '维护商品表（再定量、再销量、价格）
        If ModifyPositionWhenDeleteOutBill(lngActivityID) = False Then GoTo DeleteErr   '维护货位批次明细表
        
        If DeleteRelation(lngActivityID_2, lngActivityTypeID_2) <> 1 Then GoTo DeleteErr   '删除关系(删除采购发票与受托结算单时须标记对应商品入库单及受托入库单)
        If ChangeAllItem_from_Activity("D", lngActivityID_2) = False Then GoTo DeleteErr
'        If ChangeAllAccount_from_Activity("D", lngActivityID_2) = False Then GoTo DeleteErr
        If ModifyItemTable(lngActivityID_2, False) = False Then GoTo DeleteErr  '维护商品表（再定量、再销量、价格）
        If ModifyPositionWhenDeleteOutBill(lngActivityID_2) = False Then GoTo DeleteErr   '维护货位批次明细表
    
    End If
        
    If Not blnByVoid Then
         strSql = "DELETE From ItemActivity WHERE lngActivityID IN (" & lngActivityID & "," & lngActivityID_2 & ")"
         gclsBase.ExecSQL strSql
         strSql = "DELETE From ItemActivityDetail WHERE lngActivityID IN (" & lngActivityID & "," & lngActivityID_2 & ")"
         gclsBase.ExecSQL strSql
    Else
        strSql = "UPDATE ItemActivity SET ItemActivity.blnIsVoid = 1 WHERE lngActivityID IN (" & lngActivityID & "," & lngActivityID_2 & ")"
        If gclsBase.ExecSQL(strSql) = False Then GoTo TheErr
    End If

'------------------------------------------------------------------------------
    If Not blnByVoid Then blnMaxNODecrease intYear, bytPeriod, lngReceiptTypeID, strReceiptNo, lngReceiptNo
'------------------------------------------------------------------------------
        
    gclsBase.BaseWorkSpace.CommitTrans
    DeleteCompose = True
    Exit Function
TheErr:
DeleteErr:
    gclsBase.BaseWorkSpace.RollBacktrans
    If Not blnByVoid Then cMsgBox "删除拆卸组装表失败！"
End Function
Public Function BindingResultSet()
   On Error Resume Next
    Me.Hide
    '得到付款条件列表记录集
    Set datGrid.Resultset = GetList()
    If Not datGrid.Resultset.EOF Then datGrid.Resultset.MoveLast
    datGrid.Resultset.Close
    
    mclsList.SetFlexGrid
    '初始化查找复合列表框
    mclsList.InitcboFindKind
    mclsList.FlexNoChange = False
    mclsList.FindNoChange = False
    '设置第一行为选定行
    With grdList
        If .Rows > 1 Then grdList.Row = 1
        .col = 0
        .ColSel = .Cols - 1
    End With
    If chkShowAll.Value = 0 Then mclsList.DoShowAll False
    Me.Show
    Me.ZOrder 0
End Function