[VB]转载 - VB中类的使用

Option Explicit
'定义一个对象变量，并指定这个变量属于这个类
'WithEvents使这个对象能响映事件
Dim WithEvents MyDeveloper As cDeveloper

Private Sub Form_Load()
Set MyDeveloper = New cDeveloper '这句一定要，这是初始化这个对象
With MyDeveloper
.Name = "求伯君" '这个程序员叫做求伯君
.EmpolderTool = "C++" '这个程序员用C++进行开发
.Empolder '调用Empolder方法使这个程序员进行开发工作
End With
End Sub
'如果开发失败，则产生EmpolderLost这个事件
Private Sub MyDeveloper_EmpolderLost()
With MyDeveloper
.Study '如果开发失败,就让这个程序员进行学习
.Empolder '学习后再次进行开发
End With
End Sub
'如果开发成功，则这个程序员成为一个优秀的程序员
Private Sub MyDeveloper_EmpolderSucceed()
MsgBox "开发成功了！" & MyDeveloper.Name & _
"成为了一个优秀的程序员", vbInformation, "恭喜"
End Sub

Option Explicit

'local variable(s) to hold property value(s)
Private mvarDeveloperName As String 'local copy
Private mvarEmpolderTool As String 'local copy
'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent EmpolderLost[(arg1, arg2, ... , argn)]
Public Event EmpolderLost()
'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent EmpolderSucceed[(arg1, arg2, ... , argn)]
Public Event EmpolderSucceed()
Public Sub Empolder()
End Sub

Public Sub Study()
End Sub

Public Property Let EmpolderTool(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.EmpolderTool = 5
mvarEmpolderTool = vData
End Property

Public Property Get EmpolderTool() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmpolderTool
EmpolderTool = mvarEmpolderTool
End Property

Public Property Let DeveloperName(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.DeveloperName = 5
mvarDeveloperName = vData
End Property

Public Property Get DeveloperName() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.DeveloperName
DeveloperName = mvarDeveloperName
End Property

Public Sub name [(ParameterList)]
[statements]
[Exit Sub]
[statements]
End Sub
这是创建一个子过程的语法规则，用这个规则，您可以很简单地创建一个子过程，请看下面的代码
Option Explicit
Private Sub Form_Load()
Quotient 100, 30
End Sub

Public Sub Quotient(dblDividend As Double, dblDivisor As Double)
Dim dblQuotient As Double
dblQuotient = dblDividend / dblDivisor
MsgBox "您提供的两参数相除的结果是：" & dblQuotient
End Sub

Private Sub Form_Load()
MsgBox "您提供的两参数相除的结果是：" & Quotient(100, 30)
End Sub

Public Function Quotient(dblDividend As Double, dblDivisor As Double) As Double
Quotient = dblDividend / dblDivisor
End Function
'我们可以看到，Quotient现在已经可以返回一个值了，因为它已不再是子过程，而是一个函数过程了。
'函数过程的语法可以写成下面这样：
Public Function name [(ParameterList)] As DataType
[statements]
[Exit Function]
[statements]
End Function 

Option Explicit
'下面这两句是用Private定义的cDeveloper类模块的内部变量，在这个类模块以外是无法访问这两个变量的，这两个变量是用来存储DeveloperName 和EmpolderTool的值的。
Private mvarDeveloperName As String
Private mvarEmpolderTool As String
'下面这两句是定义的两个事件，语法很简单，不是吗？如果这个事件象MouseMove这种事件一样是要带参数的， 可以用Public Event EventName(Parameter1 as ParameterType,Parameter2 as ParameterType)这种方式来声明这个事件。
Public Event EmpolderLost()
Public Event EmpolderSucceed()
'下面分别声明的是两个方法，通过上面的讨论，您可以看出来，这其实就是一个子过程。当您的方法是要返回值的时候，您就要把下而的子过程改写成一个函数过程，也就是把其中的Sub改成Function，并且声明返回值的类型，您也可以在“（）”中加入要传递进去的参数。
Public Sub Empolder()
End Sub

Public Sub Study()
End Sub

Public Property Let EmpolderTool(ByVal vData As String)
mvarEmpolderTool = vData
End Property

Public Property Get EmpolderTool() As String
EmpolderTool = mvarEmpolderTool
End Property

Public Property Let DeveloperName(ByVal vData As String)
mvarDeveloperName = vData
End Property

Public Property Get DeveloperName() As String
DeveloperName = mvarDeveloperName
End Property 

Option Explicit

'local variable(s) to hold property value(s)
Private mvarDeveloperName As String 'local copy
Private mvarEmpolderTool As String 'local copy
'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent EmpolderLost[(arg1, arg2, ... , argn)]
Public Event EmpolderLost()
'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent EmpolderSucceed[(arg1, arg2, ... , argn)]
Public Event EmpolderSucceed()
Public Sub Empolder()
Dim intSucceed As Integer 'Msgbox返回的是Integer变量,所以这里定义为Integer变量,您当然也可以定义它为Long,因为Long的存储空间大于Integer.
MsgBox "现在进行开发"
intSucceed = MsgBox("开发成功了吗?", vbYesNo + vbQuestion + vbDefaultButton2, "问题")
If intSucceed = vbYes Then 'vbYes是一个VB常量,它的值是一个Integer型的数据.
RaiseEvent EmpolderSucceed '如果开发成功,则激发EmpolderSucceed事件
Else
RaiseEvent EmpolderLost '如果没有开发成功,则激发EmpolderLost事件
End If
End Sub

Public Sub Study()
MsgBox mvarDeveloperName & ":请您进一步学习您的" & mvarEmpolderTool & "开发工具", vbInformation, "注意"
'在这里,您看到了对mvarDeveloperName和mvarEmpolderTool的调用,
'因为这是从类的内部调用DeveloperName属性和EmpolderTool属性,所以可以直接访问存储这两个属性的
'模块内部变量mvarDeveloperName和mvarEmpolderTool.
End Sub

Public Property Let EmpolderTool(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.EmpolderTool = 5
mvarEmpolderTool = vData
End Property

Public Property Get EmpolderTool() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmpolderTool
EmpolderTool = mvarEmpolderTool
End Property

Public Property Let DeveloperName(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.DeveloperName = 5
mvarDeveloperName = vData
End Property

Public Property Get DeveloperName() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.DeveloperName
DeveloperName = mvarDeveloperName
End Property

Option Explicit
Private WithEvents MyDeveloper As cDeveloper
Private Sub Command1_Click()

With MyDeveloper
.DeveloperName = "黄河"
.EmpolderTool = "C++"
.Empolder
End With

End Sub

Private Sub Form_Load()
Set MyDeveloper = New cDeveloper
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set MyDeveloper = Nothing
End Sub

Private Sub MyDeveloper_EmpolderLost()
With MyDeveloper
.Study
End With
End Sub

Private Sub MyDeveloper_EmpolderSucceed()
With MyDeveloper
MsgBox .DeveloperName & ":您已经用您的" & .EmpolderTool & "工具成功完成了您的开发工作"
End With
End Sub 

Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const MAX_COMPUTERNAME_LENGTH& = 15
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub Command1_Click()
Dim lngReturn As Long
Dim lngSize As Long
Dim sBuffer As String
Dim lSize As Long
Dim strUserName As String
Dim strComputerName As String
'1.取得计算机名
strComputerName = String$(MAX_COMPUTERNAME_LENGTH + 1, 0)
lngSize = MAX_COMPUTERNAME_LENGTH + 1
lngReturn = GetComputerName(strComputerName, lngSize)
'2.取得Windows当前登录用户名
sBuffer = Space$(255)
lSize = Len(sBuffer)
Call GetUserName(sBuffer, lSize)
If lSize > 0 Then
strUserName = CStr(Trim(Left$(sBuffer, lSize - 1)))
Else
strUserName = vbNullString
End If
MsgBox "当前用户为：" & strUserName & " ；计算机名为：" & strComputerName
End Sub 

Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const MAX_COMPUTERNAME_LENGTH& = 15
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private mvarComputerName As String

Public Property Get ComputerName() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ComputerName
Dim s$
Dim dl&
Dim sz&
If mvarComputerName = "" Then
s$ = String$(MAX_COMPUTERNAME_LENGTH + 1, 0)
sz& = MAX_COMPUTERNAME_LENGTH + 1
dl& = GetComputerName(s$, sz)
mvarComputerName = s
ComputerName = mvarComputerName
End If
End Property

'通过API，取得windows系统登录用户ID
Public Function GetTheUserName() As String
Dim sBuffer As String
Dim lSize As Long
sBuffer = Space$(255)
lSize = Len(sBuffer)
Call GetUserName(sBuffer, lSize)
If lSize > 0 Then
GetTheUserName = CStr(Trim(Left$(sBuffer, lSize - 1)))
Else
GetTheUserName = vbNullString
End If
End Function 

Private Sub Command1_Click()
Dim myUser As New cUser
MsgBox "当前用户为：" & myUser.GetTheUserName & " ；计算机名为：" & myUser.ComputerName
Set myUser = Nothing
End Sub 

CREATE TABLE [dbo].[Users] (
[ID] [int] NOT NULL ,
[UserName] [char] (10) NOT NULL ,
[UserPassword] [char] (10) NOT NULL
）

Private Sub Command1_Click()
Dim Rs As New ADODB.Recordset
Dim strSQL As String
strSQL = "select * from Users where ID=1"
Rs.Open strSQL, conn, adOpenKeyset, adLockReadOnly, adCmdText
Text1 = Rs!UserName
Text2 = Rs!UserPassword
Text3=Rs!ID
Rs.Close
Set Rs = Nothing
End Sub

Option Explicit
Private MyConn As ADODB.Connection , mvarUserName As String
Private mvarUserPassword As String , mvarUserID As Long
Public Event ReferSucceed(ByVal Information As String) '提交成功事件
Public Event ReferLost(ByVal Information As String) '提交失败事件
Public Function SetConn(TheConn As ADODB.Connection) As Boolean
Set MyConn = TheConn
End Function
Public Function DeleteUserInfo(Optional UserID As Long = 0) As Boolean
Dim Rs As New ADODB.Recordset
Dim strSQL As String
On Error GoTo SysErr
strSQL = "SELECT * FROM USERS WHERE UserID=" & UserID
Rs.Open strSQL, MyConn, adOpenKeyset, adLockOptimistic, adCmdText
On Error GoTo 0
If Not Rs.EOF Then
Rs.Delete
RaiseEvent ReferSucceed("删除" & UserID & "成功！")
DeleteUserInfo = True
Else
RaiseEvent ReferLost(UserID & "编号无记录！请检查您的条件")
DeleteUserInfo = False
End If
Rs.Close
Set Rs = Nothing
Exit Function
SysErr:
RaiseEvent ReferLost("意外错误！请检查您的数据库连接是否成功。")
End Function

'下面这个方法中的参数SaveType用于判断SaveUserInfo是插入新记录还是修改旧记录
'当SaveType=0时,为修改旧记录,
'当SaveType<>0时,为插入新记录.
Public Function SaveUserInfo(UserID As Long, Optional SaveType As Long = 0) As Boolean
Dim Rs As New ADODB.Recordset
Dim strSQL As String
On Error GoTo SysErr '下面这两句如果有错误,是意外错误用专门的错误处理程序处理
strSQL = "SELECT * FROM USERS WHERE UserID=" & UserID
'注意下面这一句中的LockTypeEnum参数不能用adLockReadOnly.而要用adLockOptimistic或者adLockPessimistic
Rs.Open strSQL, MyConn, adOpenKeyset, adLockOptimistic, adCmdText
On Error GoTo 0 '以上的错误是容易处理的,所以取消错误处理
If SaveType = 0 Then '如果SaveType=0则为添加新记录方式
If Rs.EOF Then
Rs.AddNew
Else
RaiseEvent ReferLost(UserID & "号用户已经存在,请重新设定您的UserID值,您的这次操作被取消!")
GoTo CloseRs
Exit Function
End If
Else '如果SaveType<>0则为修改旧记录
If Rs.EOF Then
RaiseEvent ReferLost(UserID & "号用户并不存在,请检查您的UserID值,您的这次操作被取消!")
GoTo CloseRs
Exit Function
End If
End If
Rs!UserID = mvarUserID
Rs!UserName = mvarUserName
Rs!UserPassword = mvarUserPassword
Rs.Update
If SaveType = 0 Then
RaiseEvent ReferSucceed("添加" & UserID & "成功！")
Else
RaiseEvent ReferSucceed("修改" & UserID & "成功！")
End If
SaveUserInfo = True
Exit Function
CloseRs:
Rs.Close
Set Rs = Nothing
Exit Function
SysErr:
RaiseEvent ReferLost("意外错误！请检查您的数据库连接是否成功。错误号" & Err.Number)
SaveUserInfo = False
End Function
Public Function GetUserInfo(Optional UserID As Long = 0) As Boolean
Dim Rs As New ADODB.Recordset
Dim strSQL As String
On Error GoTo SysErr
strSQL = "SELECT * FROM USERS WHERE UserID=" & UserID
Rs.Open strSQL, MyConn, adOpenKeyset, adLockReadOnly, adCmdText
On Error GoTo 0
If Not Rs.EOF Then
If Rs.RecordCount > 1 Then
RaiseEvent ReferLost("返回的记录不唯一," & UserID & "编号有" & Rs.RecordCount & "条记录！请检查您的数据库记录")
GetUserInfo = False
Else
mvarUserID = Rs!UserID
mvarUserName = Rs!UserName
mvarUserPassword = Rs!UserPassword
RaiseEvent ReferSucceed("查询" & UserID & "成功！")
GetUserInfo = True
End If
Else
RaiseEvent ReferLost(UserID & "编号无记录！请检查您的条件")
GetUserInfo = False
End If
Rs.Close
Set Rs = Nothing
Exit Function
SysErr:
RaiseEvent ReferLost("意外错误！请检查您的数据库连接是否成功。")
GetUserInfo = False
End Function
Public Property Let UserID(ByVal vData As Long)
mvarUserID = vData
End Property
Public Property Get UserID() As Long
UserID = mvarUserID
End Property
Public Property Let UserPassword(ByVal vData As String)
mvarUserPassword = vData
End Property
Public Property Get UserPassword() As String
UserPassword = mvarUserPassword
End Property
Public Property Let UserName(ByVal vData As String)
mvarUserName = vData
End Property
Public Property Get UserName() As String
UserName = mvarUserName
End Property 

Option Explicit
Public conn As New ADODB.Connection
Sub main() '这是程序启动的地方
Dim strConnString As String
strConnString = "Provider=SQLOLEDB;" & _
"Persist Security Info=True;" & _
"User ID=sa;" & _
"Initial Catalog=pubs;" & _
"Data Source=ntserver"
conn.Open strConnString '打开数据库连接
Form1.Show
End Sub 

Option Explicit
Public WithEvents MyUser As cUsers
Private Sub cmdAddNew_Click()
MyUser.UserID = Text1
MyUser.UserName = Text2
MyUser.UserPassword = Text3
MyUser.SaveUserInfo CLng(Text1), 0
End Sub
Private Sub cmdDelete_Click()
If MyUser.DeleteUserInfo(CLng(Text1)) Then
Text1 = ""
Text2 = ""
Text3 = ""
End If
End Sub
Private Sub cmdQuery_Click()
If MyUser.GetUserInfo(CLng(Text1)) Then
Text1 = MyUser.UserID
Text2 = MyUser.UserName
Text3 = MyUser.UserPassword
End If
End Sub
Private Sub cmdUpdate_Click()
MyUser.UserID = Text1
MyUser.UserName = Text2
MyUser.UserPassword = Text3
MyUser.SaveUserInfo CLng(Text1), 1
End Sub
Private Sub Form_Load()
Set MyUser = New cUsers
MyUser.SetConn conn '把数据库联接传递给类
End Sub
Private Sub Form_Unload(Cancel As Integer)
conn.Close
Set conn = Nothing
Set MyUser = Nothing
End Sub
Private Sub MyUser_ReferLost(ByVal Information As String)
MsgBox Information
End Sub
Private Sub MyUser_ReferSucceed(ByVal Information As String)
MsgBox Information
End Sub 

Public Property Let UserName(ByVal vData As String)
mvarUserName = vData
End Property
Public Property Get UserName() As String
UserName = mvarUserName
End Property 

Public UserName As String 

Public Property Let UserName(ByVal vData As String)
mvarUserName = vData
End Property 

Public Property Let UserName(ByVal vData As String)
mvarUserName = vData
End Property 

Public Property Let UserName(ByVal vData As String)
If vData=”” Then
Msgbox “用户名为空！”
Else
mvarUserName = vData
End If
End Property 

Private mvntAnything As Variant

Public Property Get Anything() As Variant
'Set 语句只用于包含了对象引用的任何属性。
If IsObject(mvntAnything) Then
Set Anything = mvntAnything
Else
Anything = mvntAnything
End If
End Property

Public Property Let Anything(ByVal NewValue As Variant)
'（省略验证代码。）
mvntAnything = NewWidget
End Property

Public Property Set Anything(ByVal NewValue As Variant)
'（省略验证代码。）
Set mvntAnything = NewWidget
End Property 

Public WithEvents MyUser1 As cUsers
Public WithEvents MyUser2 As cUsers
…………
Set MyUser1=New cUser
Set MyUser2=New cUser
…………

Option Explicit
Public WithEvents MyUser As cUsers
Public colUser As Collection
Private Sub cmdAddNew_Click()
Set MyUser = New cUsers '创建一个用户
MyUser.UserID = Text1
MyUser.UserName = Text2
MyUser.UserPassword = Text3
colUser.Add MyUser, Text1
Set MyUser = Nothing
End Sub

Private Sub cmdDelete_Click()
colUser.Remove CLng(Text1)
Text1 = ""
Text2 = ""
Text3 = ""
End Sub

Private Sub cmdQuery_Click()
Set MyUser = New cUsers
On Error GoTo Err
Set MyUser = colUser(Text1)
On Error GoTo 0
Text1 = MyUser.UserID
Text2 = MyUser.UserName
Text3 = MyUser.UserPassword
Set MyUser = Nothing
Exit Sub
Err:
MsgBox "没有这个用户"
End Sub

Private Sub cmdUpdate_Click()
Set MyUser = New cUsers
On Error GoTo Err
Set MyUser = colUser(Text1)
On Error GoTo 0
MyUser.UserID = Text1
MyUser.UserName = Text2
MyUser.UserPassword = Text3
Set MyUser = Nothing
Exit Sub
Err:
MsgBox "无此用户"
End Sub

Private Sub Form_Load()
Set colUser = New Collection '在这里创建这个集合的一个实例
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set MyUser = Nothing
Set colUser = Nothing
End Sub 

Private Type MyUser
    UserID As Long
    UserName As String
    Password As String
End Type