xsfhdh.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 = "XsFhdh"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Dim m_Kh As Kh
Dim m_CwBz As CwBz
Dim m_CwQj As CwQj

Dim m_XsFhds As XsFhds

Dim m_XsFhdhType As Integer

Dim m_XsFhdhDocno As String
Dim m_XsFhdhDat As String

Dim m_XsFhdh_CwqjCode As String
Dim m_XsFhdh_CwqjNo As Double

Dim m_XsFhdh_KhCode As String
Dim m_XsFhdh_Khno As Double

Dim m_XsFhdh_CwBzCode As String
Dim m_XsFhdh_CwBzno As Double

Dim m_XsFhdhForm As String

Dim m_XsFhdhNo As Double

Dim m_XsFhdhId As Integer
Dim m_XsFhdhKey As Double

Private Sub Class_Initialize()
   m_XsFhdhId = -1
End Sub

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

Public Property Get Kh() As Kh
   If m_Kh Is Nothing Then
      Set m_Kh = New Kh
      If m_XsFhdh_KhCode <> "" Then
         m_Kh.Requery m_XsFhdh_KhCode
      End If
   End If
   Set Kh = m_Kh
End Property

Public Property Get CwQj() As CwQj
   If m_CwQj Is Nothing Then
      Set m_CwQj = New CwQj
      If m_XsFhdh_CwqjCode <> "" Then
         m_CwQj.Requery m_XsFhdh_CwqjCode
      End If
   End If
   Set CwQj = m_CwQj
End Property

Public Property Get CwBz() As CwBz
   If m_CwBz Is Nothing Then
      Set m_CwBz = New CwBz
      If m_XsFhdh_CwBzCode <> "" Then
         m_CwBz.Requery m_XsFhdh_CwBzCode
      End If
   End If
   Set CwBz = m_CwBz
End Property

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

Public Property Get XsFhdhId() As Integer
   XsFhdhId = m_XsFhdhId
End Property

Public Property Get XsFhdhKey() As Double
   XsFhdhKey = m_XsFhdhKey
End Property

Public Property Get XsFhdhType() As Integer
   XsFhdhType = m_XsFhdhType
End Property

Public Property Get XsFhdhDocno() As String
   XsFhdhDocno = m_XsFhdhDocno
End Property

Public Property Get XsFhdhDat() As String
   XsFhdhDat = m_XsFhdhDat
End Property

Public Property Get XsFhdh_CwQjCode() As String
   XsFhdh_CwQjCode = m_XsFhdh_CwqjCode
End Property

Public Property Get XsFhdh_CwqjNo() As Double
   XsFhdh_CwqjNo = m_XsFhdh_CwqjNo
End Property

Public Property Get XsFhdh_KhCode() As String
   XsFhdh_KhCode = m_XsFhdh_KhCode
End Property

Public Property Get XsFhdh_Khno() As Double
   XsFhdh_Khno = m_XsFhdh_Khno
End Property

Public Property Get XsFhdh_CwBzCode() As String
   XsFhdh_CwBzCode = m_XsFhdh_CwBzCode
End Property

Public Property Get XsFhdh_CwBzno() As Double
   XsFhdh_CwBzno = m_XsFhdh_CwBzno
End Property

Public Property Get XsFhdhForm() As String
   XsFhdhForm = m_XsFhdhForm
End Property

Public Property Get XsFhdhNo() As Double
   XsFhdhNo = m_XsFhdhNo
End Property

Public Property Let XsFhdhId(vXsFhdhId As Integer)
   m_XsFhdhId = vXsFhdhId
End Property

Public Property Let XsFhdhKey(vXsFhdhKey As Double)
   m_XsFhdhKey = vXsFhdhKey
End Property

Public Property Let XsFhdhType(vXsFhdhType As Integer)

   If vXsFhdhType <> 1 And vXsFhdhType <> 2 Then
      Err.Raise vbObjectError + 1, , "发货单类型只能为1-采购发货单，2-采购退货单！"
      Exit Property
   End If
   
   m_XsFhdhType = vXsFhdhType
   
End Property

Public Property Let XsFhdhDocno(vXsFhdhDocno As String)

   If Trim(vXsFhdhDocno) = "" Then
      Err.Raise vbObjectError + 1, , "发货单号不能为空！"
      Exit Property
   End If
   
   If m_XsFhdhDocno <> vXsFhdhDocno Then
      Dim Rs As DbRs
      Set Rs = New DbRs
      Rs.Fillbydb "SELECT * FROM XsFhdHREC WHERE XsFhdHDOCNO='" & vXsFhdhDocno & "'"
      If Not Rs.EOF Then
         Set Rs = Nothing
         Err.Raise vbObjectError + 1, , "发货单号已经存在！"
         Exit Property
      End If
      Set Rs = Nothing
   End If
   
   m_XsFhdhDocno = vXsFhdhDocno
   
End Property

Public Property Let XsFhdhDat(vXsFhdhDat As String)

   If Trim(vXsFhdhDat) = "" Then
      Err.Raise vbObjectError + 1, , "发货日期不能为空！"
      Exit Property
   End If
   
   m_XsFhdh_CwqjCode = gPublicFunction.GetCwqjCode(vXsFhdhDat)
   CwQj.Requery m_XsFhdh_CwqjCode
   m_XsFhdh_CwqjNo = CwQj.CwQjNo
   m_XsFhdhDat = vXsFhdhDat
   
End Property

Public Property Let XsFhdh_KhCode(vXsFhdh_KhCode As String)

   If Trim(vXsFhdh_KhCode) = "" Then
      Err.Raise vbObjectError + 1, , "客户编码不能为空！"
      Exit Property
   End If
   
   If m_XsFhdh_KhCode <> vXsFhdh_KhCode Then
      If Kh.Requery(vXsFhdh_KhCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的客户编码不存在！"
         Exit Property
      End If
      m_XsFhdh_Khno = Kh.KhNo
      m_XsFhdh_CwBzCode = Kh.Kh_CwBzCode
      m_XsFhdh_CwBzno = Kh.Kh_CwBzno
   End If
   
   m_XsFhdh_KhCode = vXsFhdh_KhCode
   
End Property

Public Property Let XsFhdh_CwQjCode(vXsFhdh_CwQjCode As String)

   If Trim(vXsFhdh_CwQjCode) = "" Then
      Err.Raise vbObjectError + 1, , "录入的财务月份不能为空！"
      Exit Property
   End If
   
   If m_XsFhdh_CwqjCode <> vXsFhdh_CwQjCode Then
      If CwQj.Requery(vXsFhdh_CwQjCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的财务月份不存在！"
         Exit Property
      End If
      m_XsFhdh_CwqjNo = CwQj.CwQjNo
   End If
   
   m_XsFhdh_CwqjCode = vXsFhdh_CwQjCode
   
End Property

Public Property Let XsFhdh_CwBzCode(vXsFhdh_CwBzCode As String)

   If Trim(vXsFhdh_CwBzCode) = "" Then
      Err.Raise vbObjectError + 1, , "录入的币种不能为空！"
      Exit Property
   End If
   
   If m_XsFhdh_CwBzCode <> vXsFhdh_CwBzCode Then
      If CwBz.Requery(vXsFhdh_CwBzCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的币种编码不存在！"
         Exit Property
      End If
      m_XsFhdh_CwBzno = CwBz.CwbzNo
   End If
   
   m_XsFhdh_CwBzCode = vXsFhdh_CwBzCode
   
End Property

Public Property Let XsFhdhForm(vXsFhdhForm As String)
   m_XsFhdhForm = vXsFhdhForm
End Property

Public Sub Save()
   Dim Cmd As ADODB.Command
On Error GoTo Errorhandle
      
   If XsFhds.Count = 0 Then
      On Error GoTo 0
      Err.Raise vbObjectError + 1, , "单据无明细行，不能存盘！"
      Exit Sub
   End If
      
   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = gDbCommon.Conn
   
   If m_XsFhdhId = -1 Then
      Cmd.CommandText = gPublicFunction.GetCallSPString("XsFhDHREC_INSERT", 8)
      Cmd(0) = m_XsFhdhType
      Cmd(1) = m_XsFhdhDocno
      Cmd(2) = m_XsFhdhDat
      Cmd(3) = m_XsFhdh_CwqjNo
      Cmd(4) = m_XsFhdh_Khno
      Cmd(5) = m_XsFhdh_CwBzno
      Cmd(6) = m_XsFhdhForm
      Cmd(7).Direction = adParamOutput   'XsFhdhNo
   Else
      Cmd.CommandText = gPublicFunction.GetCallSPString("XsFhdhREC_UPDATE", 6)
      Cmd(0) = m_XsFhdhNo
      Cmd(1) = m_XsFhdhDocno
      Cmd(2) = m_XsFhdhDat
      Cmd(3) = m_XsFhdh_CwqjNo
      Cmd(4) = m_XsFhdh_Khno
      Cmd(5) = m_XsFhdh_CwBzno
   End If
   
   gDbCommon.Conn.BeginTrans
   Cmd.Execute
   If m_XsFhdhId = -1 Then
      m_XsFhdhNo = Cmd(7)
   End If
   XsFhds.Save Me
   gDbCommon.Conn.CommitTrans
   
   If m_XsFhdhId = -1 Then
      m_XsFhdhId = 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(Optional mMxDel As Integer = 0)
   Dim Cmd As ADODB.Command
On Error GoTo Errorhandle
      
   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = gDbCommon.Conn
   
   Cmd.CommandText = "{CALL XsFhdHREC_DELETE(?)}"
   Cmd(0) = m_XsFhdhNo
   
   If mMxDel = 0 Then
      gDbCommon.Conn.BeginTrans
   End If
   Cmd.Execute
   If mMxDel = 0 Then
      gDbCommon.Conn.CommitTrans
   End If
   
   Set Cmd = Nothing
   
Exit Sub
Errorhandle:
   Set Cmd = Nothing
   If mMxDel = 0 Then
      gDbCommon.Conn.RollbackTrans
   End If
   Err.Raise vbObjectError + 1, , gDbCommon.Conn.Errors(0)
End Sub

Public Function Requery(Optional vXsFhdhDocno As String = "", Optional vXsFhdhno As Double = 0) As Integer
   Dim mRs As DbRs
   Dim mSqlStr As String
On Error GoTo Errorhandle

   Requery = -1
   
   mSqlStr = "SELECT XsFhDHTYPE,XsFhdHDOCNO,XsFhdHDAT,XsFhdH_KHCODE=COALESCE((SELECT KHCODE FROM KHREC WHERE KHNO=XsFhDH_KHNO),''),XsFhdH_KHNO,"
   mSqlStr = mSqlStr & "XsFhdh_CwQjCode=COALESCE((SELECT CWQJCODE FROM CWQJREC WHERE CWQJNO=XsFhdh_CwQjno),''),XsFhdh_CwQjno,"
   mSqlStr = mSqlStr & "XsFhdh_CwBzCode=COALESCE((SELECT CWBZCODE FROM CWBZREC WHERE CWBZNO=XsFhdh_CwBzno),''),XsFhdh_CwBzno,"
   mSqlStr = mSqlStr & "XsFhDHFORM,XsFhdHNO FROM XsFhdHREC WHERE (XsFhdHDOCNO='" & vXsFhdhDocno & "' OR XsFhdHNO=" & CStr(vXsFhdhno) & ") "
   
   Set mRs = New DbRs
   mRs.Fillbydb mSqlStr
   
   If Not mRs.EOF Then
      Requery = 1
      BatchLet mRs!XsFhdhType, mRs!XsFhdhDocno, mRs!XsFhdhDat, mRs!XsFhdh_CwQjCode, mRs!XsFhdh_CwqjNo, mRs!XsFhdh_KhCode, mRs!XsFhdh_Khno, mRs!XsFhdh_CwBzCode, mRs!XsFhdh_CwBzno, mRs!XsFhdhForm, mRs!XsFhdhNo
   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_XsFhdhType = Properties(0)
   m_XsFhdhDocno = Properties(1)
   m_XsFhdhDat = Properties(2)
   m_XsFhdh_CwqjCode = Properties(3)
   m_XsFhdh_CwqjNo = Properties(4)
   m_XsFhdh_KhCode = Properties(5)
   m_XsFhdh_Khno = Properties(6)
   m_XsFhdh_CwBzCode = Properties(7)
   m_XsFhdh_CwBzno = Properties(8)
   m_XsFhdhForm = Properties(9)
   m_XsFhdhNo = Properties(10)

   m_XsFhdhId = 1

End Sub