scd.cls

制造业产供销与往来系统源码,包括进销存及全部控件！

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Scd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Dim m_PsBm As PsBm
Dim m_Hwbm As Hwbm
Dim m_HwDw As HwDw

Dim m_Scdms As Scdms

Dim m_ScdType As Integer

Dim m_ScdDocno As String
Dim m_ScdDat As String

Dim m_Scd_PsBmCode As String
Dim m_Scd_PsBmMc As String
Dim m_Scd_PsBmno As Double

Dim m_Scd_HwBmCode As String
Dim m_Scd_HwBmMc As String
Dim m_Scd_HwBmno As Double

Dim m_Scd_HwDwCode As String
Dim m_Scd_HwDwNo As Double
Dim m_Scd_HwDwConv As Double

Dim m_ScdQty As Double
Dim m_ScdWQty As Double

Dim m_ScdBDat As String
Dim m_ScdWDat As String

Dim m_ScdBz As String

Dim m_ScdForm As String
Dim m_ScdNo As Double

Dim m_ScdId As Integer
Dim m_ScdKey As Double

Private Sub Class_Initialize()
   m_ScdId = -1
End Sub

Public Property Get Name() As String
   Name = "Scd"
End Property

Public Property Get ScdId() As Integer
   ScdId = m_ScdId
End Property

Public Property Let ScdId(vScdId As Integer)
   m_ScdId = vScdId
End Property

Public Property Get ScdKey() As Double
   ScdKey = m_ScdKey
End Property

Public Property Let ScdKey(vScdKey As Double)
   m_ScdKey = vScdKey
End Property

Public Property Get Scdms() As Scdms
   If m_Scdms Is Nothing Then
      Set m_Scdms = New Scdms
      m_Scdms.Fillbydb Me
   End If
   Set Scdms = m_Scdms
End Property

Public Property Get PsBm() As PsBm
   If m_PsBm Is Nothing Then
      Set m_PsBm = New PsBm
      If m_Scd_PsBmCode <> "" Then
         m_PsBm.Requery m_Scd_PsBmCode
      End If
   End If
   Set PsBm = m_PsBm
End Property

Public Property Get Hwbm() As Hwbm
   If m_Hwbm Is Nothing Then
      Set m_Hwbm = New Hwbm
      If m_Scd_HwBmCode <> "" Then
         m_Hwbm.Requery m_Scd_HwBmCode
      End If
   End If
   Set Hwbm = m_Hwbm
End Property

Public Property Get HwDw() As HwDw
   If m_HwDw Is Nothing Then
      Set m_HwDw = New HwDw
      If m_Scd_HwDwCode <> "" Then
         m_HwDw.Requery m_Scd_HwDwCode
      End If
   End If
   Set HwDw = m_HwDw
End Property

Public Property Get ScdType() As Integer
   ScdType = m_ScdType
End Property

Public Property Get ScdDocno() As String
   ScdDocno = m_ScdDocno
End Property

Public Property Get ScdDat() As String
   ScdDat = m_ScdDat
End Property

Public Property Get Scd_PsBmCode() As String
   Scd_PsBmCode = m_Scd_PsBmCode
End Property

Public Property Get Scd_PsBmMc() As String
   Scd_PsBmMc = m_Scd_PsBmMc
End Property

Public Property Get Scd_PsBmno() As Double
   Scd_PsBmno = m_Scd_PsBmno
End Property

Public Property Get Scd_HwBmCode() As String
   Scd_HwBmCode = m_Scd_HwBmCode
End Property

Public Property Get Scd_HwBmMc() As String
   Scd_HwBmMc = m_Scd_HwBmMc
End Property

Public Property Get Scd_HwBmno() As Double
   Scd_HwBmno = m_Scd_HwBmno
End Property

Public Property Get Scd_HwDwCode() As String
   Scd_HwDwCode = m_Scd_HwDwCode
End Property

Public Property Get Scd_HwDwno() As Double
   Scd_HwDwno = m_Scd_HwDwNo
End Property

Public Property Get Scd_HwDwConv() As Double
   Scd_HwDwConv = m_Scd_HwDwConv
End Property

Public Property Get ScdQty() As Double
   ScdQty = m_ScdQty
End Property

Public Property Get ScdWQty() As Double
   ScdWQty = m_ScdWQty
End Property

Public Property Get ScdBDat() As String
   ScdBDat = m_ScdBDat
End Property

Public Property Get ScdWDat() As String
   ScdWDat = m_ScdWDat
End Property

Public Property Get ScdBz() As String
   ScdBz = m_ScdBz
End Property

Public Property Get ScdForm() As String
   ScdForm = m_ScdForm
End Property

Public Property Get ScdNo() As Double
   ScdNo = m_ScdNo
End Property

Public Property Let ScdType(vScdType As Integer)
   m_ScdType = vScdType
End Property

Public Property Let ScdDocno(vScdDocno As String)

   If Trim(vScdDocno) = "" Then
      Err.Raise vbObjectError + 1, , "生产单号不能为空！"
      Exit Property
   End If
   
   If m_ScdDocno <> vScdDocno Then
      Dim Rs As DbRs
      Set Rs = New DbRs
      Rs.Fillbydb "SELECT * FROM ScdREC WHERE ScdDOCNO='" & vScdDocno & "'"
      If Not Rs.EOF Then
         Set Rs = Nothing
         Err.Raise vbObjectError + 1, , "生产单号已经存在！"
         Exit Property
      End If
      Set Rs = Nothing
   End If
   
   m_ScdDocno = vScdDocno
   
End Property

Public Property Let ScdDat(vScdDat As String)

   If Trim(vScdDat) = "" Then
      Err.Raise vbObjectError + 1, , "日期不能为空！"
      Exit Property
   End If
   
   If gPublicFunction.IsDateValid(vScdDat) = 0 Then
      Err.Raise vbObjectError + 1, , "下单日期不正确！"
      Exit Property
   End If
   
   m_ScdDat = vScdDat
   
End Property

Public Property Let Scd_PsBmCode(vScd_PsBmCode As String)

   If Trim(vScd_PsBmCode) = "" Then
      m_Scd_PsBmno = 0
      m_Scd_PsBmCode = ""
      m_Scd_PsBmMc = ""
      Exit Property
   End If
   
   If m_Scd_PsBmCode <> vScd_PsBmCode Then
      If PsBm.Requery(vScd_PsBmCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的部门不存在！"
         Exit Property
      End If
      m_Scd_PsBmno = PsBm.PsBmNo
      m_Scd_PsBmMc = PsBm.PsBmMc
   End If
   
   m_Scd_PsBmCode = vScd_PsBmCode
   
End Property

Public Property Let Scd_HwBmCode(vScd_HwBmCode As String)
   If Trim(vScd_HwBmCode) = "" Then
      Err.Raise vbObjectError + 1, , "货物编码不能为空！"
      Exit Property
   End If
   If m_Scd_HwBmCode <> vScd_HwBmCode Then
      If Hwbm.Requery(vScd_HwBmCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的货物编码不存在！"
         Exit Property
      End If
      m_Scd_HwBmno = Hwbm.HwBmNo
      m_Scd_HwBmMc = Hwbm.HwBmMc
      m_Scd_HwDwCode = Hwbm.HwBm_HwDwCode
      m_Scd_HwDwNo = Hwbm.HwBm_HwDwNo
      m_Scd_HwDwConv = 1
   End If
   m_Scd_HwBmCode = vScd_HwBmCode
End Property

Public Property Let Scd_HwDwCode(vScd_HwDwCode As String)
   If Trim(vScd_HwDwCode) = "" Then
      Err.Raise vbObjectError + 1, , "计量单位不能为空！"
      Exit Property
   End If
   If m_Scd_HwDwCode <> vScd_HwDwCode Then
      If HwDw.Requery(vScd_HwDwCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的计量单位不存在！"
         Exit Property
      End If
      m_Scd_HwDwNo = HwDw.HwDwNo
   End If
   m_Scd_HwDwCode = vScd_HwDwCode
End Property

Public Property Let Scd_HwDwConv(vScd_HwdwConv As Double)
   If vScd_HwdwConv <= 0 Then
      Err.Raise vbObjectError + 1, , "换算系数必须大于零！"
      Exit Property
   End If
   m_Scd_HwDwConv = vScd_HwdwConv
End Property

Public Property Let ScdQty(vScdQty As Double)
   If vScdQty <= 0 Then
      Err.Raise vbObjectError + 1, , "数量必须大于零！"
      Exit Property
   End If
   m_ScdQty = vScdQty
End Property

Public Property Let ScdBDat(vScdBDat As String)

   If Trim(vScdBDat) = "" Then
      m_ScdBDat = ""
      Exit Property
   End If
   
   If gPublicFunction.IsDateValid(vScdBDat) = 0 Then
      Err.Raise vbObjectError + 1, , "开工日期不正确！"
      Exit Property
   End If
   
   m_ScdBDat = vScdBDat
   
End Property

Public Property Let ScdWDat(vScdWDat As String)

   If Trim(vScdWDat) = "" Then
      m_ScdWDat = ""
      Exit Property
   End If
   
   If gPublicFunction.IsDateValid(vScdWDat) = 0 Then
      Err.Raise vbObjectError + 1, , "要求完工日期不正确！"
      Exit Property
   End If
   
   m_ScdWDat = vScdWDat
   
End Property

Public Property Let ScdBz(vScdDBz As String)
   m_ScdBz = vScdDBz
End Property

Public Property Let ScdForm(vScdForm As String)
   m_ScdForm = vScdForm
End Property

Public Sub Save()
   Dim Cmd As ADODB.Command
On Error GoTo ErrorHandle
      
   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = gDbCommon.Conn
            
   If m_ScdId = -1 Then
      Cmd.CommandText = gPublicFunction.GetCallSPString("SCDREC_INSERT", 13)
      Cmd(0) = m_ScdType
      Cmd(1) = m_ScdDocno
      Cmd(2) = m_ScdDat
      Cmd(3) = m_Scd_PsBmno
      Cmd(4) = m_Scd_HwBmno
      Cmd(5) = m_Scd_HwDwNo
      Cmd(6) = m_Scd_HwDwConv
      Cmd(7) = m_ScdQty
      Cmd(8) = m_ScdBDat
      Cmd(9) = m_ScdWDat
      Cmd(10) = m_ScdBz
      Cmd(11) = m_ScdForm
      Cmd(12).Direction = adParamOutput      'ScdNo
   Else
      Cmd.CommandText = gPublicFunction.GetCallSPString("SCDREC_UPDATE", 11)
      Cmd(0) = m_ScdNo
      Cmd(1) = m_ScdDocno
      Cmd(2) = m_ScdDat
      Cmd(3) = m_Scd_PsBmno
      Cmd(4) = m_Scd_HwBmno
      Cmd(5) = m_Scd_HwDwNo
      Cmd(6) = m_Scd_HwDwConv
      Cmd(7) = m_ScdQty
      Cmd(8) = m_ScdBDat
      Cmd(9) = m_ScdWDat
      Cmd(10) = m_ScdBz
   End If
   
   gDbCommon.Conn.BeginTrans
   Cmd.Execute
   If m_ScdId = -1 Then
      m_ScdNo = Cmd(12)
   End If
   Scdms.Save Me
   gDbCommon.Conn.CommitTrans
   
   If m_ScdId = -1 Then
      m_ScdId = 1
   End If
   
   Set Cmd = Nothing
   
Exit Sub
ErrorHandle:
   Set Cmd = Nothing
   gDbCommon.Conn.RollbackTrans
   Err.Raise vbObjectError + 1, , gDbCommon.Conn.Errors(0)
End Sub

Public Sub Del()
   Dim Cmd As ADODB.Command
   
   gPublicFunction.CheckCanBeDelete "SCDREC", "SCDNO", CStr(m_ScdNo)
   
On Error GoTo ErrorHandle

   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = gDbCommon.Conn
      
   Cmd.CommandText = "{CALL SCDREC_DELETE(?)}"
   Cmd(0) = m_ScdNo
   
   gDbCommon.Conn.BeginTrans
   Cmd.Execute
   gDbCommon.Conn.CommitTrans
   
   Set Cmd = Nothing
   
Exit Sub
ErrorHandle:
   Set Cmd = Nothing
   gDbCommon.Conn.RollbackTrans
   Err.Raise vbObjectError + 1, , gDbCommon.Conn.Errors(0)
End Sub

Public Function Requery(Optional vScdDocno As String = "", Optional vScdNo As Double = 0) As Integer
   Dim mRs As DbRs
   Dim mSqlStr As String
On Error GoTo ErrorHandle
   Requery = -1
   
   Set mRs = New DbRs
   
   mSqlStr = "SELECT SCDTYPE,SCDDOCNO,SCDDAT,"
   mSqlStr = mSqlStr & "Scd_PsBmCODE=COALESCE((SELECT PsBmCODE FROM PsBmREC WHERE PsBmNO=Scd_PsBmNO),''),Scd_PsBmMc=COALESCE((SELECT PsBmMc FROM PsBmREC WHERE PsBmNO=Scd_PsBmNO),''),Scd_PsBmNO,"
   mSqlStr = mSqlStr & "Scd_HwBmCode=COALESCE((SELECT HwBmCode FROM HWBMREC WHERE HWBMNO=Scd_HWBMNO),''),Scd_HwBmMc=COALESCE((SELECT HwBmMc FROM HWBMREC WHERE HWBMNO=Scd_HWBMNO),''),Scd_HWBMNO,"
   mSqlStr = mSqlStr & "Scd_HwDwCode=COALESCE((SELECT HWDWCode FROM HWDWREC WHERE HWDWNO=Scd_HWDWNO),''),Scd_HWDWNO,Scd_HWDWCONV,"
   mSqlStr = mSqlStr & "ScdQTY,SCDWQTY,SCDBDAT,SCDWDAT,ScdBZ,SCDFORM,ScdNO FROM ScdREC WHERE (SCDDOCNO='" & vScdDocno & "' OR ScdNO=" & CStr(vScdNo) & ")"
   
   mRs.Fillbydb mSqlStr
   
   If Not mRs.EOF Then
      Requery = 1
      BatchLet mRs!ScdType, mRs!ScdDocno, mRs!ScdDat, mRs!Scd_PsBmCode, mRs!Scd_PsBmMc, mRs!Scd_PsBmno, mRs!Scd_HwBmCode, mRs!Scd_HwBmMc, mRs!Scd_HwBmno, _
               mRs!Scd_HwDwCode, mRs!Scd_HwDwno, mRs!Scd_HwDwConv, _
               mRs!ScdQty, mRs!ScdWQty, mRs!ScdBDat, mRs!ScdWDat, mRs!ScdBz, mRs!ScdForm, mRs!ScdNo
   End If
   Set mRs = Nothing
   
Exit Function
ErrorHandle:
   Set mRs = Nothing
   Err.Raise vbObjectError + 1, , Err.Description
End Function

Public Sub BatchLet(ParamArray Properties() As Variant)
   
   m_ScdType = Properties(0)
   m_ScdDocno = Properties(1)
   m_ScdDat = Properties(2)
   
   m_Scd_PsBmCode = Properties(3)
   m_Scd_PsBmMc = Properties(4)
   m_Scd_PsBmno = Properties(5)
   
   m_Scd_HwBmCode = Properties(6)
   m_Scd_HwBmMc = Properties(7)
   m_Scd_HwBmno = Properties(8)
   
   m_Scd_HwDwCode = Properties(9)
   m_Scd_HwDwNo = Properties(10)
   m_Scd_HwDwConv = Properties(11)
   
   m_ScdQty = Properties(12)
   m_ScdWQty = Properties(13)
   
   m_ScdBDat = Properties(14)
   m_ScdWDat = Properties(15)
   
   m_ScdBz = Properties(16)
   m_ScdForm = Properties(17)
   m_ScdNo = Properties(18)

   m_ScdId = 1

End Sub

Public Sub GenScdm()
   Dim Cmd As ADODB.Command
On Error GoTo ErrorHandle

   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = gDbCommon.Conn
   
   Cmd.CommandText = "{CALL SCDREC_GENSCDM(?)}"
   Cmd(0) = m_ScdNo
   
   Cmd.Execute

   Set Cmd = Nothing

Exit Sub
ErrorHandle:
   Set Cmd = Nothing
   Err.Raise vbObjectError + 1, , gDbCommon.Conn.Errors(0)
End Sub