hwbm.cls

用vb和SQLSERVER编译的关于数据库的源程序例子。

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

Dim Conn As ADODB.Connection
Dim Cmd As ADODB.Command

Dim m_HwBmFlCode As String
Dim m_HwBmCode As String
Dim m_HwBmMc As String
Dim m_HwBmPrice As Double
Dim m_HwBmDat As Date

Dim D_HwBmCode As String

Dim m_HwBmId As Integer
Dim m_HwBmKey As Integer

Private Sub Class_Initialize()
   
   m_HwBmId = -1
   
   Set Conn = New ADODB.Connection
   Conn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Password=;Initial Catalog=fiterp;Data Source=ERP002"
   Conn.Open
   Conn.CursorLocation = adUseClient
   
   Set Cmd = New ADODB.Command
   Set Cmd.ActiveConnection = Conn
   
End Sub

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

Public Property Get HwbmId() As Integer
   HwbmId = m_HwBmId
End Property

Public Property Get HwbmKey() As Integer
   HwbmKey = m_HwBmKey
End Property

Public Property Get HwBmFlCode() As String
   HwBmFlCode = m_HwBmFlCode
End Property

Public Property Get HwBmCode() As String
   HwBmCode = m_HwBmCode
End Property

Public Property Get HwBmMc() As String
   HwBmMc = m_HwBmMc
End Property

Public Property Get HwBmPrice() As Double
   HwBmPrice = m_HwBmPrice
End Property

Public Property Get HwBmDat() As Date
   HwBmDat = m_HwBmDat
End Property

Public Property Let HwbmId(vHwbmId As Integer)
   m_HwBmId = vHwbmId
End Property

Public Property Let HwbmKey(vHwbmKey As Integer)
   m_HwBmKey = vHwbmKey
End Property

Public Property Let HwBmFlCode(vHwBmFlCode As String)

   If Trim(vHwBmFlCode) = "" Then
      Err.Raise vbObjectError + 1, , "货物分类码不能为空！"
      Exit Property
   End If
   
   Dim Rs As ADODB.Recordset
   Set Rs = New ADODB.Recordset
   Set Rs.ActiveConnection = Conn
   Rs.Open "SELECT * FROM HWFLREC WHERE HWFLCODE='" & vHwBmFlCode & "'"
   
   If Rs.EOF Then
      Rs.Close
      Set Rs = Nothing
      Err.Raise vbObjectError + 1, , "选择的货物分类码不存在！"
      Exit Property
   End If
   
   Rs.Close
   Set Rs = Nothing
   
   m_HwBmFlCode = vHwBmFlCode
   
End Property

Public Property Let HwBmCode(vHwBmCode As String)

   If Trim(vHwBmCode) = "" Then
      Err.Raise vbObjectError + 1, , "货物编码不能为空！"
      Exit Property
   End If
   
   Dim Rs As ADODB.Recordset
   Set Rs = New ADODB.Recordset
   Set Rs.ActiveConnection = Conn
   
   Rs.Open "SELECT * FROM HWBMREC WHERE HWBMCODE='" & vHwBmCode & "'"
   
   If Not Rs.EOF Then
      Rs.Close
      Set Rs = Nothing
      Err.Raise vbObjectError + 1, , "货物编码已经存在！"
      Exit Property
   End If
   
   Rs.Close
   Set Rs = Nothing
   
   m_HwBmCode = vHwBmCode
   
End Property

Public Property Let HwBmMc(vHwBmMc As String)

   If Trim(vHwBmMc) = "" Then
      Err.Raise vbObjectError + 1, , "货物名称不能为空！"
      Exit Property
   End If
   
   m_HwBmMc = vHwBmMc
   
End Property

Public Property Let HwBmPrice(vHwBmPrice As Double)

   If vHwBmPrice < 0 Then
      Err.Raise vbObjectError + 1, , "货物单价不能小于零！"
      Exit Property
   End If
   
   m_HwBmPrice = vHwBmPrice
   
End Property

Public Sub Save()
On Error GoTo Errorhandle
      
   If m_HwBmId = -1 Then
      Cmd.CommandText = "{CALL VBSQLPROADD(?,?,?,?)}"
      Cmd(0) = m_HwBmFlCode
      Cmd(1) = m_HwBmCode
      Cmd(2) = m_HwBmMc
      Cmd(3) = m_HwBmPrice
   Else
      Cmd.CommandText = "{CALL VBSQLPROUPDATE(?,?,?,?,?)}"
      Cmd(0) = D_HwBmCode
      Cmd(1) = m_HwBmFlCode
      Cmd(2) = m_HwBmCode
      Cmd(3) = m_HwBmMc
      Cmd(4) = m_HwBmPrice
   End If
   
   Conn.BeginTrans
   Cmd.Execute
   Conn.CommitTrans
   
   D_HwBmCode = m_HwBmCode
   m_HwBmId = 1
   
Exit Sub
Errorhandle:
   Conn.RollbackTrans
   Err.Raise vbObjectError + 1, , Err.Description
End Sub

Public Sub Del()
On Error GoTo Errorhandle
      
   Cmd.CommandText = "{CALL VBSQLPRODELETE(?)}"
   Cmd(0) = D_HwBmCode
   
   Conn.BeginTrans
   Cmd.Execute
   Conn.CommitTrans
   
Exit Sub
Errorhandle:
   Conn.RollbackTrans
   Err.Raise vbObjectError + 1, , Err.Description
End Sub

Public Function Requery(vHwBmCode As String) As Integer
   Dim mRs As ADODB.Recordset
On Error GoTo Errorhandle
   Requery = -1
   Set mRs = Conn.Execute("SELECT HWBMFLCODE,HWBMCODE,HWBMMC,HWBMPRICE,HWBMDAT FROM HWBMREC WHERE HWBMCODE='" & vHwBmCode & "'")
   If Not mRs.EOF Then
      BatchLet mRs!HwBmFlCode, mRs!HwBmCode, mRs!HwBmMc, mRs!HwBmPrice, mRs!HwBmDat
   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_HwBmFlCode = Properties(0)
   m_HwBmCode = Properties(1)
   m_HwBmMc = Properties(2)
   m_HwBmPrice = Properties(3)
   m_HwBmDat = Properties(4)
   
   D_HwBmCode = m_HwBmCode
   m_HwBmId = 1

End Sub

Private Sub Class_Terminate()
   Set Conn = Nothing
   Set Cmd = Nothing
End Sub