frmitemlistcard.frm

金算盘软件代码

         Width           =   1095
      End
      Begin VB.Label lblNote 
         AutoSize        =   -1  'True
         Caption         =   "常用货位(&O)"
         Height          =   180
         Index           =   23
         Left            =   150
         TabIndex        =   14
         Top             =   1800
         Width           =   990
      End
      Begin VB.Label lblNote 
         Caption         =   "所属类型(&L)"
         Height          =   195
         Index           =   2
         Left            =   150
         TabIndex        =   6
         Top             =   1170
         Width           =   1125
      End
      Begin VB.Label lblNote 
         Caption         =   "商品编码(&C)"
         Height          =   195
         Index           =   0
         Left            =   150
         TabIndex        =   0
         Top             =   510
         Width           =   1155
      End
      Begin VB.Label lblNote 
         Caption         =   "商品名称(&N)"
         Height          =   225
         Index           =   26
         Left            =   150
         TabIndex        =   4
         Top             =   825
         Width           =   1125
      End
      Begin VB.Label lblNote 
         Caption         =   "规格型号(&V)"
         Height          =   225
         Index           =   1
         Left            =   3630
         TabIndex        =   8
         Top             =   1170
         Width           =   1095
      End
      Begin VB.Label lblNote 
         Caption         =   "商品货号(&I)"
         Height          =   225
         Index           =   3
         Left            =   3630
         TabIndex        =   12
         Top             =   1485
         Width           =   1095
      End
      Begin VB.Label lblNote 
         Caption         =   "商品产地(&E)"
         Height          =   225
         Index           =   4
         Left            =   150
         TabIndex        =   10
         Top             =   1485
         Width           =   1095
      End
   End
End
Attribute VB_Name = "frmItemListCard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''
'
'新增、编辑商品劳务卡片
'
'作者：苏涛
'
'日期:1998-07-14
'
'接口:EditCard(lngID,ShowModual),DelCard(lngID) As Boolean
'
''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Text

'Private Const WM_KEYDOWN = &H100

Private mclsGrid As Grid
Private mclsUnitGrid As Grid
Private mblnFirstClick(0 To 11) As Boolean
Private mblnIsInit As Boolean
Private mblnIsChanged As Boolean
Private mblnIsComItem As Boolean
Private mblnIsNew As Boolean
Private mblnExit As Boolean
Private mblnIsStock As Boolean
Private mbytShowDec As Byte
Private mbytPriceDec As Byte
Private mbytQuantityDec As Byte
Private mintCboIndex As Integer
Private mlngCol As Long
Private mlngRow As Long
Private mlngUnitGridCol As Long
Private mlngUnitGridRow As Long
Private mlngItemID As Long
Private mlngDItemID As Long       '编码合并时的目标ID
Private mlngMinUnitID As Long
Private mlngStockUnitID As Long
Private mlngMinRow As Long
Private mlngStockRow As Long
'Private mdblFactor As Double
Private mstrMinUnit As String
Private mstrStockUnit As String
Private mstrCode As String
Private mstrItem As String
Private mstrNotes As String
Private mstrItemCategory As String
Private mlngOldLst(0 To 11) As Long
Private WithEvents mclsMainControl As MainControl               '主控对象
Attribute mclsMainControl.VB_VarHelpID = -1

Public Property Get getID()
    getID = mlngItemID
End Property

Public Function DelCard(ByVal lngID As Long) As Boolean
    Dim recItem As rdoResultset, strSql As String
    Dim strItem As String
    
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    DelCard = False
    
    If lngID = mlngItemID And frmItemList.IsShowCard(1) Then
        ShowMsg 0, "不能删除正在修改的商品！", vbExclamation + MB_TASKMODAL, "删除商品"
        Show
        GoTo ErrHandle
    End If
    
    strSql = "SELECT * FROM Item WHERE lngItemID=" & lngID
    Set recItem = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recItem.EOF Then
        recItem.Close
        DelCard = True
        GoTo ErrHandle
    Else
        strItem = Trim(recItem!strItemCode) & " " & Trim(recItem!strItemName)
        recItem.Close
    End If
    If frmItemCard.ItemIsUsed(lngID) Then
        ShowMsg 0, "商品“" & strItem & "”已经发生业务,不能删除！", _
            vbExclamation + MB_TASKMODAL, "删除商品"
        GoTo ErrHandle
    End If
    
    If ShowMsg(0, "你确实要删除商品“" & strItem & "”吗?", _
        vbQuestion + vbYesNo + MB_TASKMODAL, "删除商品") = vbNo Then
            GoTo ErrHandle
    End If
    strSql = "DELETE FROM Item WHERE lngItemID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    strSql = "DELETE FROM ItemUnit WHERE lngItemID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    strSql = "DELETE FROM ItemCombination WHERE lngCombinationItemID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    gclsBase.BaseWorkSpace.CommitTrans
    
    DelCard = True
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
'    gclsSys.SendMessage Me.hwnd, Message.msgItem
End Function

Public Function AddCard(Optional strName As String = "", Optional intModal As Integer = 0) As Long
    
    If IsContinue Then Exit Function
    mlngItemID = 0
    mblnIsNew = True
'    mblnIsChanged = True
    Caption = "新增商品劳务"
    cmdOK(2).Default = True
    InitCard 0, strName
    Show intModal
    AddCard = mlngItemID
    Refresh
    ZOrder 0
    Unload MsgForm
End Function

'新增(LNGID=0)或编辑商品
Public Sub EditCard(ByVal lngID As Long, Optional intModal As Integer = 0, Optional strItem As String)
    Dim strMess As String
    
    If IsContinue Then Exit Sub
    mstrItem = strItem
    If Not CheckIDUsed("Item", "lngItemID", lngID) Then
        If Trim(strItem) <> "" Then
            strMess = "“" & mstrItem & "”"
        Else
            strMess = "该"
        End If
        ShowMsg 0, strMess & "商品不存在,不能进行修改！", _
            vbExclamation + MB_TASKMODAL, "修改商品劳务"
        Unload Me
    Else
        mlngItemID = lngID
        mblnIsNew = False
        mblnIsChanged = False
        Caption = "修改商品劳务"
        cmdOK(0).Default = True
        InitCard mlngItemID
        Show intModal
        Refresh
        ZOrder 0
    End If
    Unload MsgForm
End Sub

Private Sub AdjustPrice(ByVal Index As Integer)
    Dim i As Integer, iCol As Integer, dblQuantity As Double, dblFactor As Double
    
    iCol = Switch(Index = 6, 5, Index = 7, 6, Index = 8, 7, Index = 12, 8)
    With msgUnit
    For i = 1 To .Rows - 1
        dblQuantity = TxtToDouble(txtItem(Index).Text)
        dblFactor = TxtToDouble(.TextMatrix(i, 4))
        .TextMatrix(i, iCol) = FormatShow(dblQuantity * dblFactor, mbytPriceDec)
    Next i
    End With
End Sub

Private Function ExchangeValueForStore(ByVal strVal As String, lngUnitID As Long, _
    blnIsForStore As Boolean) As Double
    Dim strSql As String, recUnit As rdoResultset
    
    strSql = "SELECT * FROM ItemUnit WHERE lngUnitID=" & lngUnitID
    Set recUnit = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
'    If blnIsForStore Then
'        ExchangeValueForStore = dblVal * recUnit!dblFactor
'    Else
'        ExchangeValueForStore = dblVal / recUnit!dblFactor
'    End If
    If Not recUnit.EOF Then
        ExchangeValueForStore = NumberConvert(strVal, recUnit!dblFactor, blnIsForStore)
        mbytShowDec = Len(CStr(recUnit!dblFactor)) - 1
    Else
        mbytShowDec = 0
    End If
    recUnit.Close
End Function

Private Sub InitPasteLst(Optional lngID As Long = 0)
    Dim strSql As String, lngItemID As Long
    
    If msgItem.TextMatrix(msgItem.Row, 5) = "" Then
        lngItemID = 0
    Else
        lngItemID = msgItem.TextMatrix(msgItem.Row, 5)
    End If
    lstItem(11).ClearRefer
    strSql = "SELECT lngUnitID,strUnitName,dblFactor FROM ItemUnit WHERE lngItemID=" _
        & lngItemID & " ORDER BY lngUnitID DESC"
    Set lstItem(11).Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    lstItem(11).SeekCol = "1,2"
    lstItem(11).AddRefer "<新增>"   '设置固定选项
    lstItem(11).AddRefer "<删除>"
    lstItem(11).AddRefer "<修改>"
    If lstItem(11).Referrows > 3 Then '设置列表框初始值
       If lngID > 0 Then lstItem(11).SeekId lngID
    End If
End Sub

Private Sub cboInput_Click()
    If cboInput.ListIndex > -1 And mlngRow > 0 And msgItem.Row > 0 And cboInput.Visible Then
        msgItem.TextMatrix(msgItem.Row, 5) = cboInput.ItemData(cboInput.ListIndex)
        msgItem.TextMatrix(msgItem.Row, 2) = cboInput.list(cboInput.ListIndex)
        If msgItem.RowData(mlngRow) = "1" Then msgItem.RowData(msgItem.Row) = "3"
        If Not mblnIsInit Then mblnIsChanged = True
    End If
End Sub

Private Sub cboInput_GotFocus()
    Dim i As Integer, lngItemID As Long
    
'    If mblnExit Then
'        mblnExit = False
'        Exit Sub
'    End If
    On Error Resume Next
    If msgItem.TextMatrix(msgItem.Row, 5) = "" Then
        lngItemID = 0
    Else
        lngItemID = msgItem.TextMatrix(msgItem.Row, 5)
    End If
    For i = 0 To cboInput.ListCount - 1
        If cboInput.list(i) = msgItem.TextMatrix(msgItem.Row, 2) Then Exit For
    Next i
    If i = cboInput.ListCount Then
        If msgItem.TextMatrix(msgItem.Row, 2) <> "" Then
            cboInput.AddItem msgItem.TextMatrix(msgItem.Row, 2)
            cboInput.ItemData(cboInput.NewIndex) = lngItemID
            cboInput.Text = msgItem.TextMatrix(msgItem.Row, 2)
        Else
            cboInput.ListIndex = 0
            msgItem.TextMatrix(msgItem.Row, 5) = cboInput.ItemData(0)
        End If
    End If
End Sub

Private Sub cboInput_KeyUP(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
        msgItem.col = 3
    End If
End Sub

Private Sub cboInput_LostFocus()
    Dim i As Integer
    With msgItem
'    .TextMatrix(mlngRow, 2) = cboInput.List(cboInput.ListIndex)
    For i = 0 To cboInput.ListCount - 1
        If cboInput.list(i) = .TextMatrix(mlngRow, 2) And _
            .RowHeight(mlngRow) <> 0 Then Exit For
    Next i
    End With
    If i < cboInput.ListCount Then cboInput.RemoveItem i
'    cboInput.Visible = False
End Sub

Private Sub cboItem_Click(Index As Integer)
    If Index = 0 Then mintCboIndex = cboItem(0).ListIndex
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub chkItem_Click(Index As Integer)
'    Dim strItem As String
'
'    strItem = txtItem(0).Text & " " & txtItem(1).Text
    Select Case Index
    Case 1
        If chkItem(1).Value = Checked And mblnIsStock Then
            txtItem(5).BackColor = &H80000005
            txtItem(5).Enabled = True
            lblNote(20).Enabled = True
        Else
            txtItem(5).BackColor = &H80000004
            txtItem(5).Text = ""
            txtItem(5).Enabled = False
            lblNote(20).Enabled = False
        End If
    Case 2
'        If chkItem(2).Value = Checked And Not mblnIsNew Then
'            If ItemIsUsed(mlngItemID) Then
'                ShowMsg hwnd, "商品“" & strItem & "”已经发生业务,不能停用！", _
'                    vbExclamation, Caption
'                chkItem(2).Value = Unchecked
'            End If
'        End If
    End Select
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub cmdOK_Click(Index As Integer)
    Dim strNextCode As String
    
    If Index <> 1 Then