frmout.frm

针对农资系统的商品进销存管理系统软件

      EndProperty
   End
   Begin VB.Label lblTitle 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "出  库  单"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   26.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   525
      Index           =   0
      Left            =   3585
      TabIndex        =   31
      Top             =   0
      Width           =   2715
   End
   Begin VB.Label lblTitle 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "出  库  单"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   26.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   525
      Index           =   1
      Left            =   3615
      TabIndex        =   32
      Top             =   30
      Width           =   2715
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "注:日期不绑定"
      ForeColor       =   &H000000FF&
      Height          =   180
      Left            =   240
      TabIndex        =   30
      Top             =   120
      Visible         =   0   'False
      Width           =   1170
   End
End
Attribute VB_Name = "frmOut"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim WithEvents adoPrimaryRs As ADODB.Recordset
Attribute adoPrimaryRs.VB_VarHelpID = -1
Dim WithEvents adoSecondaryRs As ADODB.Recordset
Attribute adoSecondaryRs.VB_VarHelpID = -1
Dim m_HouseRs As ADODB.Recordset
Dim m_byType As Byte
Dim m_sWaresCode As String, m_bIsSelectWares As Boolean
Dim m_bEdit As Boolean, m_bAuditer As Boolean, m_bKeeper As Boolean

Dim YearCol As Integer, MonthCol As Integer, TypeCol As Integer, NoCol As Integer
Dim CodeCol As Integer, NameCol As Integer, SpecCol As Integer, MeasCol As Integer
Dim QuantityCol As Integer, PriceCol As Integer, MoneyCol As Integer

Property Let OutType(bEdit As Boolean, bAuditer As Boolean, bKeeper As Boolean, byType As Byte)
    m_bEdit = bEdit
    m_bAuditer = bAuditer
    m_bKeeper = bKeeper
    m_byType = byType
End Property

Private Sub InitScreenObject()
    If m_byType = OUT_SELL Then
        Me.Caption = "出库单"
        lblTitle(0).Caption = "出  库  单"
        lblTitle(1).Caption = "出  库  单"
    ElseIf m_byType = OUT_OTHER Then
        Me.Caption = "代管出库单"
        lblTitle(0).Caption = "代管出库单"
        lblTitle(1).Caption = "代管出库单"
    ElseIf m_byType = OUT_RED Then
        Me.Caption = "退库单"
        lblTitle(0).Caption = "退  库  单"
        lblTitle(1).Caption = "退  库  单"
        lblTitle(0).ForeColor = QBColor(3)
    End If
    
    Set m_HouseRs = New ADODB.Recordset
    m_HouseRs.Open "Select FHouseCode, FHouseName From Warehouse Order by FHouseCode", m_gDBCnn
    With dacHouse
        Set .RowSource = m_HouseRs
        .ListField = "FHouseName"
        .BoundColumn = "FHouseCode"
    End With
End Sub

'////////////////////////////////////////////////
'//日期不绑定
Private Sub BoundingScreenObject()
    Dim ctl As Control
    For Each ctl In Me.Controls
        If TypeOf ctl Is TextBox Then
            If UCase(ctl.Name) <> "TXTFINDNO" Then
                Set ctl.DataSource = adoPrimaryRs
            End If
        End If
    Next
    Set dacHouse.DataSource = adoPrimaryRs
End Sub

Private Sub RefreshDataGrid(nYear As Integer, byMonth As Byte, byType As Byte, sNo As String)
    Dim sSqlStr As String
    Dim sGrdWidth As String, i As Integer, j As Integer
    
    Set adoSecondaryRs = Nothing
    Set adoSecondaryRs = New ADODB.Recordset
    With adoSecondaryRs
        sSqlStr = "SELECT OutDetail.FWaresCode, WaresList.FName, WaresList.FSpecName, WaresList.FMeasurement, OutDetail.FQuantity, OutDetail.FPrice, OutDetail.FYear, OutDetail.FMonth, OutDetail.FType, OutDetail.FNo " & _
            " FROM WaresOut INNER JOIN (WaresList INNER JOIN OutDetail ON WaresList.FWaresCode = OutDetail.FWaresCode) ON (WaresOut.FNo = OutDetail.FNo) AND (WaresOut.FType = OutDetail.FType) AND (WaresOut.FMonth = OutDetail.FMonth) AND (WaresOut.FYear = OutDetail.FYear)" & _
            " Where OutDetail.FYear = " & nYear & " And OutDetail.FMonth = " & byMonth & " And OutDetail.FType = " & byType & " And OutDetail.FNo = '" & sNo & "' Order by OutDetail.FWaresCode"
        
        .Open sSqlStr, m_gDBCnn, adOpenDynamic, adLockOptimistic, adCmdUnknown
        If m_byType = OUT_OTHER Then
            .Properties("Unique Table") = "OutDetail"
            .Properties("Resync Command") = "SELECT * FROM (" & sSqlStr & ") WHERE FWaresCode = ? And FYear = ? And FMonth = ? And FType = ? And FNo = ?"
            .Properties("Update Resync") = adResyncAll Or adResyncUpdates Or adResyncInserts Or adResyncConflicts
        End If
    End With
    
    With grdDataGrid
        Set .DataSource = adoSecondaryRs
        sGrdWidth = GetPrivateSetting(Me.Caption, "GrdWidth", "")
        .RowHeight = GetPrivateSetting(Me.Caption, "GrdHeight", "275")
        
        i = 0
        .Columns(i).Caption = "商品编码"
        SetColumnWidth sGrdWidth, .Columns(i), 1200
        .Columns(i).Locked = IIf(byType = OUT_SELL, True, False)
        .Columns(i).Button = IIf(byType = OUT_SELL, False, True)
        CodeCol = i
        i = i + 1
        .Columns(i).Caption = "名称"
        SetColumnWidth sGrdWidth, .Columns(i), 1500
        .Columns(i).Locked = True
        NameCol = i
        i = i + 1
        .Columns(i).Caption = "规格"
        SetColumnWidth sGrdWidth, .Columns(i), 1200
        .Columns(i).Locked = True
        SpecCol = i
        i = i + 1
        .Columns(i).Caption = "计量单位"
        SetColumnWidth sGrdWidth, .Columns(i), 1000
        .Columns(i).Locked = True
        MeasCol = i
        
        i = i + 1
        .Columns(i).Caption = "数量"
        SetColumnWidth sGrdWidth, .Columns(i), 1000
        .Columns(i).Locked = True
        QuantityCol = i
        
        i = i + 1
        .Columns(i).Caption = "单价"
        SetColumnWidth sGrdWidth, .Columns(i), 1000
        PriceCol = i
        
        For j = i + 1 To i + 4  'FYear, FMonth, FType, FNo
            .Columns(j).Visible = False
            .Columns(j).AllowSizing = False
            .Columns(j).Locked = True
            SetColumnWidth sGrdWidth, .Columns(j), 0
        Next
        YearCol = i + 1
        MonthCol = i + 2
        TypeCol = i + 3
        NoCol = i + 4
    End With
End Sub

Private Sub adoPrimaryRs_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    Dim sNo As String
    
    With adoPrimaryRs
        If .EOF Or .BOF Or IsNull(![FNo]) Then
            sNo = ""
            maskDate.Text = "____年__月__日"
            lblStatus.Caption = ""
        Else
            sNo = ![FNo]
            maskDate.Text = Format(![FDate], "YYYY年MM月DD日")
            lblStatus.Caption = "序号: " & CStr(adoPrimaryRs.AbsolutePosition)
        End If
    End With
    
    RefreshDataGrid m_gnYear, m_gbyMonth, m_byType, sNo
End Sub

Private Sub adoPrimaryRs_Error(ByVal ErrorNumber As Long, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
'    MsgBox "Data error event hit err:" & Description
    fCancelDisplay = True
End Sub

Private Sub adoPrimaryRs_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    '验证代码置于此处
    '下列动作发生时该事件被调用
    Dim bCancel As Boolean
    
    Select Case adReason
    Case adRsnAddNew
    Case adRsnClose
    Case adRsnDelete
    Case adRsnFirstChange
    Case adRsnMove
    Case adRsnRequery
    Case adRsnResynch
    Case adRsnUndoAddNew
    Case adRsnUndoDelete
    Case adRsnUndoUpdate
    Case adRsnUpdate
    End Select
    
    If bCancel Then adStatus = adStatusCancel
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        SendKeys "{Tab}"
    End If
End Sub

Private Sub Form_Load()
    SetForm Me, 9
    InitScreenObject
    
    Dim sSqlStr As String
    Set adoPrimaryRs = New ADODB.Recordset
    With adoPrimaryRs
        sSqlStr = "Select FYear, FMonth, FType, FNo, FDate, FHouseCode, FStoreMan,  FKeeper, FAuditer, FMaker " & _
            " From Waresout Where FYear = " & m_gnYear & " And FMonth = " & m_gbyMonth & " And FType = " & m_byType & " Order by FNo"
        .Open sSqlStr, m_gDBCnn, adOpenDynamic, adLockOptimistic, adCmdUnknown
        If Not (.EOF And .BOF) Then .MoveLast
    End With
    
    BoundingScreenObject
    SetButtons (True)
    
    m_bIsSelectWares = False
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    '当窗体调整时会调整网格
    lblTitle(0).Left = (Me.ScaleWidth - lblTitle(0).Width) / 2
    lblTitle(1).Left = lblTitle(0).Left + 30
    
    With grdDataGrid
        .Left = 50
        .Width = Me.ScaleWidth - .Left * 2
        .Height = Me.ScaleHeight - .Top - picButtons.Height - picStatBox.Height
    End With
    
    txtFindNo.Left = Me.ScaleWidth - txtFindNo.Width - 50
    lblFindNo.Left = txtFindNo.Left - lblFindNo.Width - 50
    
    cmdLast.Left = lblFindNo.Left - 340 - 300
    cmdNext.Left = cmdLast.Left - 340
    
    lblStatus.Width = cmdNext.Left - lblStatus.Left - 20
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Screen.MousePointer = vbDefault
End Sub

'///////////////////////////////////////////////////
'//
Private Sub cmdAdd_Click()
    With adoPrimaryRs
        .AddNew
        cmdUpdate.Left = cmdAdd.Left
        lblStatus.Caption = "添加单据"
        SetButtons (False)
        
        ![FYear] = m_gnYear
        ![FMonth] = m_gbyMonth
        ![FType] = m_byType
        ![FNo] = GetNewInvoiceNo("Select Max(FNo) From WaresOut Where FType = " & m_byType, 0)
        ![FDate] = Format(m_gLoginDate, "YYYY年MM月DD日")
        ![FMaker] = m_gsOperator
        .Update
        
        RefreshDataGrid ![FYear], ![FMonth], ![FType], ![FNo]
        maskDate.Text = Format(![FDate], "YYYY年MM月DD日")
        dacHouse.SetFocus
    End With
End Sub

Private Sub cmdDelete_Click()
    Dim nRet As Integer
    
    With adoPrimaryRs
        If .EOF Or .BOF Then
            Exit Sub
        End If
        
        nRet = MsgBox("您真的要删除当前单据吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
        If nRet = vbYes Then
            '先删除单据明细
            m_gDBCnn.Execute "Delete * From OutDetail Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FType = " & ![FType] & " And FNo = '" & ![FNo] & "'"
            '再删除单据头
            .Delete
            .MoveNext
            If .EOF And .RecordCount > 0 Then .MoveLast
        End If
    End With
    
    SetButtons (True)
End Sub

Private Sub cmdEdit_Click()
    If adoPrimaryRs.EOF Or adoPrimaryRs.BOF Then Exit Sub
    
    cmdUpdate.Left = cmdEdit.Left
    lblStatus.Caption = "修改单据"
    SetButtons (False)
    If m_byType = OUT_SELL Or m_byType = OUT_RED Then
        txtStoreMan.SetFocus
    Else
        dacHouse.SetFocus
    End If
End Sub

Private Function UpdateInvoice() As Boolean
    On Error GoTo UpdateErr
    
    With adoPrimaryRs
        If Not CheckDataValidity() Then
            UpdateInvoice = False
            Exit Function
        End If
        
        ![FDate] = maskDate.Text
        .Update
    End With
    On Error Resume Next
    adoSecondaryRs.Update
    
    UpdateInvoice = True
    Exit Function
    
UpdateErr:
    UpdateInvoice = False
    MsgBox "数据输入有误, 请修改!", vbOKOnly + vbExclamation, "提示："
End Function

Private Sub cmdUpdate_Click()
    If UpdateInvoice() Then
        lblStatus.Caption = "序号: " & CStr(adoPrimaryRs.AbsolutePosition)
        SetButtons (True)
    End If
End Sub

Private Sub cmdAuditer_Click()
 Dim sPrompt  As String
    If m_byType = OUT_OTHER Then '代管出库单检查数量
        Dim Rs As ADODB.Recordset
        Set Rs = adoSecondaryRs.Clone
        
        Rs.Filter = "FQuantity<=0"
        If Rs.RecordCount > 0 Then
          
            sPrompt = "下述商品的数量不大于0 " & vbCr
            Rs.MoveFirst
            Do While Not Rs.EOF
                sPrompt = sPrompt & Rs!FWaresCode & vbCr
                Rs.MoveNext
            Loop
            Rs.Close
            MsgBox sPrompt
            Exit Sub
        End If
        Rs.Close
    ElseIf m_byType = OUT_RED Then
        Dim Rs1 As ADODB.Recordset
        Set Rs1 = adoSecondaryRs.Clone
        
        Rs1.Filter = "Fprice<=0 "
        If Rs1.RecordCount > 0 Then
           
            sPrompt = "下述商品的价格不大于0 " & vbCr
            Rs1.MoveFirst
            Do While Not Rs1.EOF
                sPrompt = sPrompt & Rs1!FWaresCode & vbCr
                Rs1.MoveNext
            Loop
            Rs1.Close
            MsgBox sPrompt
            Exit Sub
        End If
        Rs1.Close
    End If
    With adoPrimaryRs
        If IsNull(![FAuditer]) Or ![FAuditer] = "" Then     '未审核
            ![FAuditer] = m_gsOperator
        Else