frmitemtable.frm

金算盘软件代码

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmItemTable 
   Caption         =   "商品批次表"
   ClientHeight    =   4800
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9165
   LinkTopic       =   "Form1"
   ScaleHeight     =   4800
   ScaleWidth      =   9165
   StartUpPosition =   3  '窗口缺省
   Begin VB.Data Data1 
      Caption         =   "Data1"
      Connect         =   "Access"
      DatabaseName    =   ""
      DefaultCursorType=   0  'DefaultCursor
      DefaultType     =   2  'UseODBC
      Exclusive       =   0   'False
      Height          =   345
      Left            =   7830
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   ""
      Top             =   4500
      Visible         =   0   'False
      Width           =   1185
   End
   Begin VB.CommandButton cmdButton 
      Height          =   435
      Index           =   4
      Left            =   7830
      Style           =   1  'Graphical
      TabIndex        =   5
      Top             =   2070
      UseMaskColor    =   -1  'True
      Width           =   1245
   End
   Begin VB.CommandButton cmdButton 
      Caption         =   "全部取消"
      Height          =   435
      Index           =   3
      Left            =   7860
      TabIndex        =   4
      Top             =   1590
      Width           =   1245
   End
   Begin VB.CommandButton cmdButton 
      Caption         =   "全部选择"
      Height          =   405
      Index           =   2
      Left            =   7830
      TabIndex        =   3
      Top             =   1200
      Width           =   1245
   End
   Begin VB.CommandButton cmdButton 
      Height          =   435
      Index           =   1
      Left            =   7860
      Style           =   1  'Graphical
      TabIndex        =   2
      Top             =   720
      UseMaskColor    =   -1  'True
      Width           =   1245
   End
   Begin VB.CommandButton cmdButton 
      Height          =   405
      Index           =   0
      Left            =   7830
      Style           =   1  'Graphical
      TabIndex        =   1
      Top             =   330
      UseMaskColor    =   -1  'True
      Width           =   1245
   End
   Begin MSFlexGridLib.MSFlexGrid grdCol 
      Bindings        =   "frmItemTable.frx":0000
      Height          =   4335
      Left            =   60
      TabIndex        =   6
      Top             =   390
      Width           =   7665
      _ExtentX        =   13520
      _ExtentY        =   7646
      _Version        =   65541
      FixedCols       =   0
      BackColorBkg    =   16777215
      GridLines       =   0
      SelectionMode   =   1
   End
   Begin VB.Label lblCaption 
      Caption         =   "lblCaption"
      Height          =   225
      Left            =   90
      TabIndex        =   0
      Top             =   30
      Width           =   4995
   End
End
Attribute VB_Name = "frmItemTable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'------------------------------------
'商品批次表
'王兴元
'1998.7
'------------------------------------
'提供给外部调用的方法：SetList (lngItemID1,Optional lngOutActivityDetailID1)
'

Const intTop = 50       '距离顶部的距离
Const intLeft = 50      '距离左边的距离

Dim clsGrid As Grid
'Dim WithEvents mclsSubClass As SubClass32.SubClass
Dim blnOK As Boolean

Private Sub cmdButton_Click(Index As Integer)
    Select Case Index
        Case 0  'OK
            cmdOK_Click
        Case 1  'Cancel
            CmdCancel_Click
        Case 2  'SelAll
            CmdSelAll_Click
        Case 3  'AllCancel
            CmdAllCancel_Click
        Case 4  'Print
            CmdPrint_Click
    End Select
End Sub

Private Sub Form_Load()
    SetHelpID Me.hwnd, 22006
    Set clsGrid = New Grid
    Set clsGrid.Grid = grdCol
    'Set mclsSubClass = New SubClass32.SubClass
    'mclsSubClass.hWnd = Me.hWnd
    'mclsSubClass.Messages(WM_GETMINMAXINFO) = True
    cmdButton(0).Picture = Utility.GetFormResPicture(1001, 0)
    cmdButton(1).Picture = Utility.GetFormResPicture(1002, 0)
    cmdButton(4).Picture = Utility.GetFormResPicture(1012, 0)
    Set grdCol.MouseIcon = Utility.GetFormResPicture(2001, 2)
End Sub
Private Sub FieldButton()
    Dim intI As Integer
    
    lblCaption.Visible = False
'    lblItemUnit.Visible = False
    For intI = 0 To cmdButton.Count - 1
        cmdButton(intI).Visible = False
    Next intI
    grdCol.Visible = False
    lblCaption.Move intLeft, intTop, 2 * strLen(lblCaption.Caption) * Me.FontSize * 10
    For intI = 0 To cmdButton.Count - 1
        cmdButton(intI).Left = Me.ScaleWidth - cmdButton(0).Width - intLeft
        cmdButton(intI).Width = cmdButton(0).Width
        cmdButton(intI).Height = cmdButton(0).Height
    Next intI
    grdCol.Move intLeft, lblCaption.top + lblCaption.Height, _
            Me.ScaleWidth - cmdButton(0).Width - 3 * intLeft, Me.ScaleHeight - lblCaption.top - lblCaption.Height - 50
    cmdButton(0).top = grdCol.top
    cmdButton(1).top = cmdButton(0).top + cmdButton(0).Height
    cmdButton(2).top = cmdButton(1).top + cmdButton(1).Height + 20
    cmdButton(3).top = cmdButton(2).top + cmdButton(2).Height
    cmdButton(4).top = cmdButton(3).top + cmdButton(3).Height + 20
'    lblItemUnit.Move lblCaption.Left + lblCaption.Width, lblCaption.Top, grdCol.Width - lblCaption.Width, lblCaption.Height
   ' lblItemUnit.Move grdCol.Width - lblItemUnit.Width, lblCaption.top, 2 * StrLen(lblItemUnit.Caption) * Me.FontSize * 10, lblCaption.Height
    lblCaption.Visible = True
  '  lblItemUnit.Visible = True
    For intI = 0 To cmdButton.Count - 1
        cmdButton(intI).Visible = True
    Next intI
    grdCol.Visible = True

End Sub
'-------------------------------------
'确定有无商品批次表记录
'-------------------------------------
Public Function SetList(ByVal lngItemID1 As Long, Optional ByVal lngOutActivityDetailID1 As Long = 0) As Boolean
    Dim recTmp As rdoResultset
    Dim Q1 As QueryDef
    Dim Strsql As String
    Dim strItemName As String
    Dim sum1 As Double
    Dim sum2 As Double
    Dim i As Long
    Dim lngPosi As Long, lngItemAc As Long
    Dim dblQ As Double
    On Error GoTo Err
'    gclsBase.BaseDB.QueryDefs("QueryItemGroup").Parameters(0).Value = ActivityDetailID
'    gclsBase.BaseDB.QueryDefs("QueryItemGroup").Parameters(1).Value = ItemID
'    Set recTmp = gclsBase.BaseDB.QueryDefs("QueryItemGroup").OpenRecordset()
    blnOK = False
    Strsql = "SELECT ItemActivityDetail.lngActivityDetailID AS 入库业务明细ID, ' ' AS 选择," & _
    "Position.[strPositionCode] & ' ' & [strPositionName] AS 货位, ItemActivityDetail.strProduceNum AS 生产批号," & _
    "PositionItemDetail.dblQuantity AS 数量, ItemActivityDetail.strProduceDate AS 生产日期, " & _
    "ItemActivityDetail.strValidDate AS 到期日期, ItemActivityDetail.intValidDay AS 保值期, " & _
    "Item.[strItemCode] & '  ' & [strItemName] AS 商品, ItemUnit.strUnitName AS 计量单位, " & _
    "PositionItemDetail.lngOutActivityDetailID AS 出库业务明细ID, Position.lngPositionID AS 货位ID," & _
    "ItemUnit.lngUnitID AS 计量单位ID, ItemUnit.dblFactor AS 折算因子,PositionItemDetail.dblQuantity AS 未折算数量 " & _
    "FROM (((PositionItemDetail INNER JOIN ItemActivityDetail ON PositionItemDetail.lngInActivityDetailID = ItemActivityDetail.lngActivityDetailID) " & _
    "LEFT JOIN ItemUnit ON ItemActivityDetail.lngUnitID = ItemUnit.lngUnitID) LEFT JOIN Position ON PositionItemDetail.lngPositionID = Position.lngPositionID) " & _
    "LEFT JOIN Item ON PositionItemDetail.lngItemID = Item.lngItemID " & _
    "WHERE ((PositionItemDetail.lngOutActivityDetailID<>0)  AND (PositionItemDetail.lngOutActivityDetailID= " & lngOutActivityDetailID1 & _
    " ) AND (PositionItemDetail.lngItemID=" & lngItemID1 & ")) OR  ((PositionItemDetail.lngItemID=" & lngItemID1 & ") AND (PositionItemDetail.lngInActivityDetailID<>0) " & _
    " AND (PositionItemDetail.lngOutActivityDetailID=0) and (PositionItemDetail.dblQuantity<>0)) " & _
    " ORDER BY Position.strPositionCode,ItemActivityDetail.strProduceNum"

    Set recTmp = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)
    If recTmp Is Nothing Or recTmp.RowCount = 0 Then
        ShowMsg Me.hwnd, "本商品需进行批次管理，但没有可使用的商品批次信息，不能出库！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "提示信息"
        'Unload Me
        Exit Function
    End If
    recTmp.MoveLast
    recTmp.MoveFirst
     Set Data1.Recordset = recTmp
'--------------Write Item,ItemUnit
     strItemName = CStr(recTmp.rdoColumns(8).Value)
     lblCaption.Caption = "商品：" & strItemName
'     strItemName = CStr(recTmp.rdocolumns(9).Value)
'     lblItemUnit.Caption = "计量单位：" & strItemName
  
    For i = 1 To grdCol.Rows - 1
        If Val(grdCol.TextMatrix(i, 10)) <> 0 Then
            grdCol.TextMatrix(i, 1) = "√"
            lngItemAc = grdCol.TextMatrix(i, 0)
            lngPosi = grdCol.TextMatrix(i, 11)
            dblQ = grdCol.TextMatrix(i, 14)
        End If
        sum1 = grdCol.TextMatrix(i, 4)
        sum2 = IIf(Len(grdCol.TextMatrix(i, 13)) = 0, 1, grdCol.TextMatrix(i, 13))
        grdCol.TextMatrix(i, 4) = NumberConvert(sum1, sum2, True)
    Next
     grdCol.ColWidth(0) = 0
     grdCol.ColWidth(1) = 450
     grdCol.ColWidth(2) = 2000
     grdCol.ColWidth(3) = 1200
     grdCol.ColWidth(4) = 1200
     grdCol.ColWidth(5) = 1000
     grdCol.ColWidth(6) = 1000
     grdCol.ColWidth(7) = 800
     'grdCol.ColAlignment(7) = 7
     'grdCol.ColAlignment(7) = 4
     grdCol.ColWidth(8) = 0      '商品 (Code+'  '+name)
     grdCol.ColWidth(9) = 0      '计量单位
     grdCol.ColWidth(10) = 0     '出库ID
     grdCol.ColWidth(11) = 0     '货位ID
     grdCol.ColWidth(12) = 0      '计量单位ID
     grdCol.ColWidth(13) = 0      '折算因子
     grdCol.ColWidth(14) = 0      '未折算数量
     clsGrid.ColOfs = 1
     grdCol.ColSel = grdCol.Cols - 1
     clsGrid.SetupStyle
     Me.Show 1
     SetList = blnOK
     If blnOK Then
        If lngOutActivityDetailID1 <> 0 Then
            mdPItem lngItemID1, lngPosi, lngItemAc, dblQ
        End If
     Else
        Unload Me
     End If
     Exit Function
Err:
    ShowMsg Me.hwnd, "系统出错！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "提示信息"
End Function

Private Sub Form_Resize()
    If Me.WindowState = 1 Then Exit Sub
    FieldButton
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Utility.RemoveFormResPicture 1001
    Utility.RemoveFormResPicture 1002
    Utility.RemoveFormResPicture 1012
    Set clsGrid = Nothing
    'Set mclsSubClass = Nothing
End Sub
Private Sub cmdOK_Click()
    If blnHave Then
        blnOK = True
        Me.Hide
        'Unload Me
    Else
        blnOK = False
        Unload Me
    End If
End Sub
Private Sub CmdCancel_Click()
    blnOK = False
    Unload Me
End Sub
Private Sub CmdSelAll_Click()
    Dim i As Integer
    For i = 1 To grdCol.Rows - 1
        If Trim(grdCol.TextMatrix(i, 1)) = "" Then
            grdCol.TextMatrix(i, 1) = "√"
        End If
    Next i
End Sub
Private Sub CmdAllCancel_Click()
    Dim i As Integer
    For i = 1 To grdCol.Rows - 1
        If Trim(grdCol.TextMatrix(i, 1)) = "√" Then
            grdCol.TextMatrix(i, 1) = ""
        End If
    Next i
End Sub
Private Sub CmdPrint_Click()
    ShowMsg Me.hwnd, "Print......", 0
End Sub

Private Sub grdCol_Click()
    If grdCol.MouseCol <> 1 Then Exit Sub
    If grdCol.Row < 1 Or grdCol.Row > grdCol.Rows Then Exit Sub
        If grdCol.TextMatrix(grdCol.Row, 1) <> "√" Then
            grdCol.TextMatrix(grdCol.Row, 1) = "√"
        Else
            grdCol.TextMatrix(grdCol.Row, 1) = ""
        End If
    grdCol.SetFocus
End Sub

Private Sub grdCol_EnterCell()
    grdCol.ColSel = grdCol.Cols - 1

End Sub

Private Sub grdCol_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case 32     '空格
            grdCol_Click
    End Select
    grdCol.SetFocus
End Sub

Private Sub grdCol_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    grdCol.ColSel = grdCol.Cols - 1
    grdCol.SetFocus
End Sub

Private Sub grdCol_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If grdCol.MouseCol = 1 Then
        grdCol.MousePointer = vbCustom
    Else
        grdCol.MousePointer = vbDefault
    End If
End Sub

Private Sub grdCol_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If grdCol.ColWidth(0) <> 0 Then grdCol.ColWidth(0) = 0
End Sub

'Private Sub mclsSubClass_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 = 8600 \ Screen.TwipsPerPixelX
'        MinMax.ptMinTrackSize.Y = 3600 \ Screen.TwipsPerPixelY
'        MinMax.ptMaxTrackSize.X = 1800
'        MinMax.ptMaxTrackSize.Y = 1600
'
'        CopyMemory ByVal lParam, MinMax, Len(MinMax)
'        Result = 0
'        Exit Sub
'    End If
'End Sub
Private Function blnHave() As Boolean
    Dim intI As Integer
    blnHave = False
    For intI = 1 To grdCol.Rows - 1
        If grdCol.TextMatrix(intI, 1) = " " Or Val(grdCol.TextMatrix(intI, 4)) = 0 Then
        Else
            blnHave = True
            Exit Function
        End If
    Next intI
End Function
'修改入库数量
Private Sub mdPItem(ByVal lngItemID1 As Long, ByVal lngPositionID1 As Long, ByVal lngInActivityDetailID1 As Long, ByVal dblQ As Double)
    Dim Strsql As String
    Dim recTemp As rdoResultset
    Strsql = " SELECT dblQuantity FROM PositionItemDetail WHERE lngItemID=" & lngItemID1 & _
    " AND lngPositionID=" & lngPositionID1 & " AND lngInActivityDetailID=" & _
    lngInActivityDetailID1 & " AND lngOutActivityDetailID=0"
    Set recTemp = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenDynaset)
    If recTemp.RowCount <= 0 Or recTemp Is Nothing Then
        recTemp.Close
        Exit Sub
    End If
    With recTemp
        .MoveFirst
        .Edit
        !dblQuantity = !dblQuantity + dblQ
        .Update
        .Close
    End With
End Sub