xsfhdarh.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 = "XsFhdArh"
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_XsFhdArs As XsFhdArs

Dim m_XsFhdArhType As Integer

Dim m_XsFhdArhDocno As String
Dim m_XsFhdArhDat As String

Dim m_XsFhdArh_CwqjCode As String
Dim m_XsFhdArh_CwqjNo As Double

Dim m_XsFhdArh_KhCode As String
Dim m_XsFhdArh_Khno As Double

Dim m_XsFhdArh_CwBzCode As String
Dim m_XsFhdArh_CwBzno As Double
Dim m_XsFhdArh_CwBzConv As Double

Dim m_XsFhdArhAmt As Double

Dim m_XsFhdArhForm As String

Dim m_XsFhdArh_ArMxNo As Double
Dim m_XsFhdArh_ArApNo As Double
Dim m_XsFhdArhNo As Double

Dim m_XsFhdArhId As Integer
Dim m_XsFhdArhKey As Double

Private Sub Class_Initialize()
   m_XsFhdArhId = -1
End Sub

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

Public Property Get Kh() As Kh
   If m_Kh Is Nothing Then
      Set m_Kh = New Kh
      If m_XsFhdArh_KhCode <> "" Then
         m_Kh.Requery m_XsFhdArh_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_XsFhdArh_CwqjCode <> "" Then
         m_CwQj.Requery m_XsFhdArh_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_XsFhdArh_CwBzCode <> "" Then
         m_CwBz.Requery m_XsFhdArh_CwBzCode
      End If
   End If
   Set CwBz = m_CwBz
End Property

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

Public Property Get XsFhdArhId() As Integer
   XsFhdArhId = m_XsFhdArhId
End Property

Public Property Get XsFhdArhKey() As Double
   XsFhdArhKey = m_XsFhdArhKey
End Property

Public Property Get XsFhdArhType() As Integer
   XsFhdArhType = m_XsFhdArhType
End Property

Public Property Get XsFhdArhDocno() As String
   XsFhdArhDocno = m_XsFhdArhDocno
End Property

Public Property Get XsFhdArhDat() As String
   XsFhdArhDat = m_XsFhdArhDat
End Property

Public Property Get XsFhdArh_CwQjCode() As String
   XsFhdArh_CwQjCode = m_XsFhdArh_CwqjCode
End Property

Public Property Get XsFhdArh_CwqjNo() As Double
   XsFhdArh_CwqjNo = m_XsFhdArh_CwqjNo
End Property

Public Property Get XsFhdArh_KhCode() As String
   XsFhdArh_KhCode = m_XsFhdArh_KhCode
End Property

Public Property Get XsFhdArh_Khno() As Double
   XsFhdArh_Khno = m_XsFhdArh_Khno
End Property

Public Property Get XsFhdArh_CwBzCode() As String
   XsFhdArh_CwBzCode = m_XsFhdArh_CwBzCode
End Property

Public Property Get XsFhdArh_CwBzno() As Double
   XsFhdArh_CwBzno = m_XsFhdArh_CwBzno
End Property

Public Property Get XsFhdArh_CwBzConv() As Double
   XsFhdArh_CwBzConv = m_XsFhdArh_CwBzConv
End Property

Public Property Get XsFhdArhForm() As String
   XsFhdArhForm = m_XsFhdArhForm
End Property

Public Property Get XsFhdArh_ArMxNo() As Double
   XsFhdArh_ArMxNo = m_XsFhdArh_ArMxNo
End Property

Public Property Get XsFhdArh_ArApNo() As Double
   XsFhdArh_ArApNo = m_XsFhdArh_ArApNo
End Property

Public Property Get XsFhdArhNo() As Double
   XsFhdArhNo = m_XsFhdArhNo
End Property

Public Property Let XsFhdArhId(vXsFhdArhId As Integer)
   m_XsFhdArhId = vXsFhdArhId
End Property

Public Property Let XsFhdArhKey(vXsFhdArhKey As Double)
   m_XsFhdArhKey = vXsFhdArhKey
End Property

Public Property Let XsFhdArhType(vXsFhdArhType As Integer)

   If vXsFhdArhType <> 1 And vXsFhdArhType <> 2 Then
      Err.Raise vbObjectError + 1, , "收货单类型只能为1-销售发货单，2-销售退货单！"
      Exit Property
   End If
   
   m_XsFhdArhType = vXsFhdArhType
   
End Property

Public Property Let XsFhdArhDocno(vXsFhdArhDocno As String)

   If Trim(vXsFhdArhDocno) = "" Then
      Err.Raise vbObjectError + 1, , "单据编号不能为空！"
      Exit Property
   End If
   
   If m_XsFhdArhDocno <> vXsFhdArhDocno Then
      Dim Rs As DbRs
      Set Rs = New DbRs
      Rs.Fillbydb "SELECT * FROM XsFhdArHREC WHERE XsFhdArHDOCNO='" & vXsFhdArhDocno & "'"
      If Not Rs.EOF Then
         Set Rs = Nothing
         Err.Raise vbObjectError + 1, , "单据编号已经存在！"
         Exit Property
      End If
      Set Rs = Nothing
   End If
   
   m_XsFhdArhDocno = vXsFhdArhDocno
   
End Property

Public Property Let XsFhdArhDat(vXsFhdArhDat As String)

   If Trim(vXsFhdArhDat) = "" Then
      Err.Raise vbObjectError + 1, , "日期不能为空！"
      Exit Property
   End If
   
   m_XsFhdArh_CwqjCode = gPublicFunction.GetCwqjCode(vXsFhdArhDat)
   CwQj.Requery m_XsFhdArh_CwqjCode
   m_XsFhdArh_CwqjNo = CwQj.CwQjNo
   m_XsFhdArhDat = vXsFhdArhDat
   
End Property

Public Property Let XsFhdArh_KhCode(vXsFhdArh_KhCode As String)

   If Trim(vXsFhdArh_KhCode) = "" Then
      Err.Raise vbObjectError + 1, , "客户编码不能为空！"
      Exit Property
   End If
   
   If m_XsFhdArh_KhCode <> vXsFhdArh_KhCode Then
      If Kh.Requery(vXsFhdArh_KhCode) = -1 Then
         Err.Raise vbObjectError + 1, , "录入的客户编码不存在！"
         Exit Property
      End If
      m_XsFhdArh_Khno = Kh.KhNo
      m_XsFhdArh_CwBzCode = Kh.Kh_CwBzCode
      m_XsFhdArh_CwBzno = Kh.Kh_CwBzno
   End If
   
   m_XsFhdArh_KhCode = vXsFhdArh_KhCode
   
End Property

Public Property Let XsFhdArh_CwQjCode(vXsFhdArh_CwQjCode As String)

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

Public Property Let XsFhdArh_CwBzCode(vXsFhdArh_CwBzCode As String)

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

Public Property Let XsFhdArhAmt(vXsFhdArhAmt As Double)
   m_XsFhdArhAmt = vXsFhdArhAmt
End Property

Public Property Let XsFhdArhForm(vXsFhdArhForm As String)
   m_XsFhdArhForm = vXsFhdArhForm
End Property

Public Sub Save()
   Dim Cmd As ADODB.Command
   Dim mXsFhdAr As XsFhdAr
On Error GoTo Errorhandle
      
   If XsFhdArs.Count = 0 Then
      On Error GoTo 0
      Err.Raise vbObjectError + 1, , "单据无明细行，不能存盘！"
      Exit Sub
   End If
   
   m_XsFhdArhAmt = 0
   For Each mXsFhdAr In XsFhdArs
      m_XsFhdArhAmt = m_XsFhdArhAmt + mXsFhdAr.XsFhdArAmt
   Next
      
   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = gDbCommon.Conn
   
   If m_XsFhdArhId = -1 Then
      Cmd.CommandText = gPublicFunction.GetCallSPString("XsFhdArHREC_INSERT", 12)
      Cmd(0) = m_XsFhdArhType
      Cmd(1) = m_XsFhdArhDocno
      Cmd(2) = m_XsFhdArhDat
      Cmd(3) = m_XsFhdArh_CwqjNo
      Cmd(4) = m_XsFhdArh_Khno
      Cmd(5) = m_XsFhdArh_CwBzno
      Cmd(6).Direction = adParamOutput
      Cmd(7) = m_XsFhdArhAmt
      Cmd(8) = m_XsFhdArhForm
      Cmd(9).Direction = adParamOutput
      Cmd(10).Direction = adParamOutput
      Cmd(11).Direction = adParamOutput   'XsFhdArhNo
   Else
      Cmd.CommandText = gPublicFunction.GetCallSPString("XsFhdArhREC_UPDATE", 8)
      Cmd(0) = m_XsFhdArhNo
      Cmd(1) = m_XsFhdArhDocno
      Cmd(2) = m_XsFhdArhDat
      Cmd(3) = m_XsFhdArh_CwqjNo
      Cmd(4) = m_XsFhdArh_Khno
      Cmd(5) = m_XsFhdArh_CwBzno
      Cmd(6).Direction = adParamOutput
      Cmd(7) = m_XsFhdArhAmt
   End If
   
   gDbCommon.Conn.BeginTrans
   Cmd.Execute
   If m_XsFhdArhId = -1 Then
      m_XsFhdArh_CwBzConv = Cmd(6)
      m_XsFhdArh_ArMxNo = Cmd(9)
      m_XsFhdArh_ArApNo = Cmd(10)
      m_XsFhdArhNo = Cmd(11)
   Else
      m_XsFhdArh_CwBzConv = Cmd(6)
   End If
   XsFhdArs.Save Me
   gDbCommon.Conn.CommitTrans
   
   If m_XsFhdArhId = -1 Then
      m_XsFhdArhId = 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 XsFhdArHREC_DELETE(?)}"
   Cmd(0) = m_XsFhdArhNo
   
   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 vXsFhdArhDocno As String = "", Optional vXsFhdArhno As Double = 0) As Integer
   Dim mRs As DbRs
   Dim mSqlStr As String
On Error GoTo Errorhandle

   Requery = -1
   
   mSqlStr = "SELECT XsFhdArHTYPE,XsFhdArHDOCNO,XsFhdArHDAT,XsFhdArH_KHCODE=COALESCE((SELECT KHCODE FROM KHREC WHERE KHNO=XsFhdArH_KHNO),''),XsFhdArH_KHNO,"
   mSqlStr = mSqlStr & "XsFhdArh_CwQjCode=COALESCE((SELECT CWQJCODE FROM CWQJREC WHERE CWQJNO=XsFhdArh_CwQjno),''),XsFhdArh_CwQjno,"
   mSqlStr = mSqlStr & "XsFhdArh_CwBzCode=COALESCE((SELECT CWBZCODE FROM CWBZREC WHERE CWBZNO=XsFhdArh_CwBzno),''),XsFhdArh_CwBzno,XsFhdArh_CwBzConv,"
   mSqlStr = mSqlStr & "XsFhdArHAMT,XsFhdArHFORM,XsFhdArh_ArMxno,XsFhdArH_ARAPNO,XsFhdArHNO FROM XsFhdArHREC WHERE (XsFhdArHDOCNO='" & vXsFhdArhDocno & "' OR XsFhdArHNO=" & CStr(vXsFhdArhno) & ") "
   
   Set mRs = New DbRs
   mRs.Fillbydb mSqlStr
   
   If Not mRs.EOF Then
      Requery = 1
      BatchLet mRs!XsFhdArhType, mRs!XsFhdArhDocno, mRs!XsFhdArhDat, mRs!XsFhdArh_CwQjCode, mRs!XsFhdArh_CwqjNo, mRs!XsFhdArh_KhCode, mRs!XsFhdArh_Khno, _
               mRs!XsFhdArh_CwBzCode, mRs!XsFhdArh_CwBzno, mRs!XsFhdArh_CwBzConv, mRs!XsFhdArhAmt, mRs!XsFhdArhForm, mRs!XsFhdArh_ArMxNo, mRs!XsFhdArh_ArApNo, mRs!XsFhdArhNo
   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_XsFhdArhType = Properties(0)
   m_XsFhdArhDocno = Properties(1)
   m_XsFhdArhDat = Properties(2)
   m_XsFhdArh_CwqjCode = Properties(3)
   m_XsFhdArh_CwqjNo = Properties(4)
   m_XsFhdArh_KhCode = Properties(5)
   m_XsFhdArh_Khno = Properties(6)
   m_XsFhdArh_CwBzCode = Properties(7)
   m_XsFhdArh_CwBzno = Properties(8)
   m_XsFhdArh_CwBzConv = Properties(9)
   m_XsFhdArhAmt = Properties(10)
   m_XsFhdArhForm = Properties(11)
   m_XsFhdArh_ArMxNo = Properties(12)
   m_XsFhdArh_ArApNo = Properties(13)
   m_XsFhdArhNo = Properties(14)

   m_XsFhdArhId = 1

End Sub