frmpositionlist.frm

金算盘软件代码

    '重画其余控件
    txtFind.Width = Me.ScaleWidth - txtFind.Left - ListFormBottom - cmdAgain.Width - 15
    cmdAgain.Left = txtFind.Left + txtFind.Width
    cmdPosition(0).top = Me.ScaleHeight - cmdPosition(0).Height - ListFormBottom
    cmdPosition(1).top = cmdPosition(0).top
    
    chkShowAll.top = cmdPosition(0).top
    chkShowAll.Left = Me.ScaleWidth - chkShowAll.Width - ListFormBottom
End Sub

Private Sub cmdPosition_Click(Index As Integer)
    Select Case Index
        Case 0
             MakeListEditMenu
             PopupMenu frmMain.mnuListEdit, , cmdPosition(0).Left, cmdPosition(0).top + cmdPosition(0).Height
       
        Case 1
            MakeListReportMenu
            PopupMenu frmMain.mnuListReport, , cmdPosition(1).Left, cmdPosition(1).top + cmdPosition(1).Height
    End Select
End Sub

'
'窗体 Form 控件
'
Private Sub Form_Load()
    Dim i As Integer
    Dim intSortCol As Integer
    Me.Hide
    Me.Left = -30000
    MsgForm.PleaseWait
    SetHelpID Me.hwnd, 30031
    '付款条件列表窗体初始化
    Debug.Print "Load Start: ", Timer
    Set mclsList = New list
    mclsList.FlexNoChange = True
    mclsList.FindNoChange = True
    Set mclsList.FlexGrid = msgTerm
    Set mclsList.FindKind = cboFindKind
    Set mclsList.Find = txtFind
    Set mclsList.Again = cmdAgain
    mclsList.ListSet.ViewId = intViewID
     mclsList.InitFlexGrid
'    Set datTerm.Resultset = GetList()
'    If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
'    datTerm.Refresh
'
'
'   ' datTerm.UpdateControls
'   ' mclsList.FlexGrid.Refresh
'   ' datTerm.Resultset.Close
'    'Set datTerm.Recordset = Nothing
'  '  datTerm.Resultset.rdoColumns.Count
'   '  mclsList.FlexGrid.Cols = 0
'   ' mclsList.FlexGrid.Cols = datTerm.Resultset.rdoColumns.Count
'
'  '  mclsList.SetFlexGrid
'    mclsList.InitcboFindKind
'    mclsList.FlexNoChange = False
'    mclsList.FindNoChange = False
'    With msgTerm
'        If .Rows > 1 Then msgTerm.Row = 1
'        .col = 0
'        .ColSel = .Cols - 1
'    End With
'    Debug.Print "Load End: ", Timer
'    mclsList.DoShowAll False
'    UpdateMenuStatus
    
     '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = msgTerm.hwnd
    mclsSubClass.Messages(WM_PAINT) = True
    mclsSubClass.Messages(WM_LBUTTONUP) = True
    mclsSubClass.Messages(WM_LBUTTONDOWN) = True
    mclsSubClass.Messages(WM_MOUSEMOVE) = True
    Set mclsSubClassform = New SubClass32.SubClass
    mclsSubClassform.hwnd = Me.hwnd
    mclsSubClassform.Messages(WM_GETMINMAXINFO) = True
    Unload MsgForm
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
End Sub

'右键菜单
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And frmMain.ActiveForm Is Me Then
        MakeListEditMenu
        PopupMenu frmMain.mnuListEdit
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = vbFormControlMenu And mIsShowCard Then
        ShowMsg Me.hwnd, "请先关闭货位卡片！", vbExclamation + MB_TASKMODAL, "货位卡片"
        Cancel = True
        frmPositionListCard.Show
        frmPositionListCard.ZOrder 0
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If mIsShowCard Then Unload frmPositionListCard
    mclsList.SaveListSet
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState = 1 Then Exit Sub
    If Me.Left + Me.Width < 0 Or Me.Left > Screen.Width Then
       Me.Left = 300
    End If
    RedrawForm
End Sub

Private Sub Form_Activate()
    mclsMainControl_ChildActive
    gclsSys.CurrFormName = Me.hwnd
    'If msgTerm.Enabled Then msgTerm.SetFocus
    msgTerm.Redraw = True
    mclsList.SetFlexGrid
    UpdateMenuStatus
    'If (Me.Left + Me.Width < 0 Or Me.Left > Screen.Width) Then Me.Left = 300
    If Me.WindowState = 1 Then Me.WindowState = 0
End Sub

'
'显示全部记录/未停用记录 CheckBox 控件
'
Private Sub chkShowAll_Click()
    msgTerm.Redraw = False
    mclsList.DoShowAll chkShowAll.Value
    msgTerm.Redraw = True
    'cboFindKind_Click
    UpdateMenuStatus
End Sub

'
'查找条件类型 ComboBox 控件
'
Private Sub cboFindKind_Click()
    Dim i As Integer
    Dim intWidth As Integer
    Dim strFind As String
    Dim intSortCol As Integer
    
    With msgTerm
        .Redraw = False
        For i = 1 To .Cols - 1
            If .TextMatrix(0, i) = cboFindKind.Text Then
                '保存新排序列内容
                strFind = .TextMatrix(.Row, i)
                '重新排序
                mclsList.FixrowSortBold i
                Exit For
            End If
       Next
    End With
   
     '恢复以前选定行
    If msgTerm.Rows > 1 Then
        If txtFind.Text = strFind Then
            txtFind_Change
        Else
            txtFind.Text = strFind
        End If
    End If
    msgTerm.Redraw = True
End Sub

Private Sub mclsMainControl_ChildActive()
     Dim vntMessage As Variant
     gclsSys.CurrFormName = Me.hwnd
    '响应消息
    For Each vntMessage In mclsMainControl.Messages
        If vntMessage = Message.msgPosition Then '接收到付款条件改变消息
            mclsMainControl_ToolRefresh
            mclsMainControl.Messages.Remove CStr(vntMessage) '清除付款条件改变消息
        End If
    Next
    mclsMainControl.Messages.Clear
    UpdateMenuStatus
End Sub

'记事薄
Private Sub mclsMainControl_EditNotepad()
    Dim i As Integer
    Dim strCode As String
    Dim strName As String
    Dim recCurren As rdoResultset
    Dim strResult As String
    Dim strSql As String
    With mclsList.FlexGrid
        If .Row > 0 Then
            For i = 0 To mclsList.ListSet.FixColumns - 1
                If .TextMatrix(0, 2 + i) = "货位编码" Then
                    strCode = .TextMatrix(.Row, 2 + i)
                ElseIf .TextMatrix(0, i + 2) = "货位名称" Then
                    strName = .TextMatrix(.Row, 2 + i)
                End If
            Next
        End If
    End With
    Set recCurren = GetByTermID(TermID)
    strResult = frmNotePad.EditCard("商品货位", strCode, strName, IIf(IsNull(recCurren!strNotes), "", recCurren!strNotes))
    'If strResult = "" Then Exit Sub
    strSql = "Update Position Set strNotes='" & strResult & "' Where lngPositionID=" & TermID
    
    gclsBase.ExecSQL (strSql)
End Sub

Private Sub mclsMainControl_FilePrintSetup()
    Dim MyPrintSet As PrintClass
    Set MyPrintSet = New PrintClass
    MyPrintSet.PrintSetUp gclsBase.BaseDB, mclsList.FlexGrid, , , , 24, " " & "," & gclsBase.BaseName & "," & gclsBase.OperatorName
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    'PositionTable
    Select Case intIndex
        Case 0
        
        'Case 2
            Report.ShowListReport 83, 137
    End Select
End Sub

Private Sub mclsSubClassForm_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim MinMax As MINMAXINFO

    If Msg = WM_GETMINMAXINFO Then
        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        
        MinMax.ptMinTrackSize.x = 430
        MinMax.ptMinTrackSize.y = 250
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
    End If
End Sub

'
'查找内容 TextBox 控件
'
Private Sub txtFind_Change()
      mclsList.TextFind txtFind.Text
End Sub

Private Sub txtFind_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim intSelLen As Integer
    If KeyCode = 8 Then
        intSelLen = txtFind.SelLength
        If txtFind.SelStart > 0 Then txtFind.SelStart = txtFind.SelStart - 1
        txtFind.SelLength = intSelLen + 1
    End If
End Sub


' FLEXGRID控件
'

'双击FLEXGRID调用卡片
Private Sub msgTerm_DblClick()
    If msgTerm.MouseRow > 0 And msgTerm.ColSel > 0 And msgTerm.MouseCol > 1 Then
        mclsMainControl_EditEdit
    End If
End Sub

'单击FLEXGRID停用列,停用或启用当前记录
Private Sub msgTerm_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim blnCancel As Boolean
    
    With msgTerm
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 Then
                If x > .ColPos(1) And x < .ColPos(2) Then
                    .MousePointer = flexHourglass
                    mclsMainControl_EditInActive
                    .MousePointer = flexDefault
                End If
            End If
        Else
            Form_MouseDown Button, Shift, x, y
        End If
    End With
End Sub

'鼠标左键弹起时，更新菜单
Private Sub msgTerm_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  
   With msgTerm
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 And .MouseRow > 0 And .Row > 0 Then
                If x > .ColPos(1) And x < .ColPos(2) Then
                    mclsMainControl_EditInActive
                End If
            End If
            UpdateMenuStatus
        End If
    End With
End Sub

'
'响应主控对象事件
'

'编辑卡片
Private Sub mclsMainControl_EditEdit()
   Me.Enabled = False
   If TermID > 0 Then frmPositionListCard.EditCard TermID
   Me.Enabled = True
End Sub

'新增卡片
Private Sub mclsMainControl_EditNew()
    frmPositionListCard.AddCard
End Sub

'删除记录
Private Sub mclsMainControl_EditDel()
    
    Dim lngID As Long
    lngID = TermID
    If mIsShowCard Then
'        If lngID = frmPositionCard.getID Then
'            MsgBox "不能删除当前编辑的付款条件！", vbExclamation
'            frmTermCard.SetFocus
'            Exit Sub
'        End If
    End If
    
    If frmPositionListCard.DelCard(TermID) Then
        
        UpDatePreFlage
        With msgTerm
            .RowHeight(.Row) = 0
            .RowData(.Row) = 1
            mclsList.SetFlexRow
        End With
        gclsSys.SendMessage CStr(Me.hwnd), Message.msgPosition
    End If
    UpdateMenuStatus
    'If Not frmPositionListCard.Visible Then
    Unload frmPositionListCard
End Sub

'停用/启用记录
Private Sub mclsMainControl_EditInActive()
'     If UpdateTermInActive(TermID, Not TermIsInActive) Then
'        With msgTerm
'            If chkShowAll.Value Then
'                If .TextMatrix(.Row, 1) = "" Then
'                    .TextMatrix(.Row, 1) = "√"
'                Else
'                    .TextMatrix(.Row, 1) = ""
'                End If
'            Else
'                .TextMatrix(.Row, 1) = "√"
'                .RowHeight(.Row) = 0
'                mclsList.SetFlexRow
'            End If
'        End With
'         gclsSys.SendMessage CStr(Me.hWnd), Message.msgPosition
'    End If
    CeaseLower
    UpdateMenuStatus
End Sub

'全部显示/显示未停用记录
Private Sub mclsMainControl_EditShowAll()
    frmMain.mnuEditShowAll.Checked = Not frmMain.mnuEditShowAll.Checked
    If chkShowAll.Value = 0 Then
        chkShowAll.Value = 1
    Else
        chkShowAll.Value = 0
    End If
End Sub

'引用编码
Private Sub mclsMainControl_EditUse()
     UseCode Message.msgPosition, TermID
    Me.ZOrder 1
End Sub

'筛选
Private Sub mclsMainControl_EditFilter()
   ' mclsList.Filter intViewID
    Dim blnFlage As Boolean
    If Not mblnIsSaveListset Then
        If Not FindlngViewID(intViewID) Then mclsList.ListSet.SaveList
        mblnIsSaveListset = True
    End If
    
    Filter.ShowFilter mclsList.ListSet.ListID, 1, , , , , blnFlage
    If Not blnFlage Then Exit Sub
    mclsList.SaveListSet
    mclsList.ListSet.ViewId = intViewID
    msgTerm.Cols = 0
    Set datTerm.Resultset = GetList()
    If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
    datTerm.Resultset.Close
    'Set datTerm.Recordset = Nothing
    mclsList.SetFlexGrid
    UpdateMenuStatus
    '初始化查找复合列表框
    mclsList.InitcboFindKind
    If chkShowAll.Value = 0 Then mclsList.DoShowAll False
    
End Sub

'栏目设置
Private Sub mclsMainControl_EditColumn()

    Dim strFind As String
    Dim strSort As String
    Dim intCount As Integer
    
    With msgTerm
        strFind = .TextMatrix(.Row, mclsList.SortCol)