这里有一段磁盘文件封装的类Option Explicit'储存文件名的类成员属性 Private m_FileName As String'储存文件描述的类成员属性 Private m_FileDesc As String'类初始化文件名的时候,说明和扩展名将设为N/A Private Sub Class_Initialize()m_FileName = "Uninitialized" m_FileDesc = "N/A"End Sub'类的公共方法,用于将文件复制到新位置 Public Sub CopyFile(NewLocation) FileCopy m_FileName, NewLocation + ParseFile End Sub '类的公共方法,用于删除程序 Public Sub DeleteFile()On Error GoTo Errorhandle Kill m_FileName Errorhandle: MsgBox vbCrLf & Err.Description Exit Sub
End Sub '为文件描述得到和设置类成员属性 Public Property Let FileDesc(s As String) m_FileDesc = s End PropertyPublic Property Get FileDesc() As String FileDesc = m_FileDesc End Property'根据现有信息获得纯粹的文件名 '例如： c:\windows\clouds.bmp 的文件名是 clouds.bmp Public Property Get file() As String file = ParseFile() End Property'为类设置和得到文件名属性 Public Property Let FileName(s As String) m_FileName = s End PropertyPublic Property Get FileName() As String FileName = m_FileName End Property'获得文件的长度 Public Property Get FileSize() As Long FileSize = FileLen(m_FileName) End Property'获得文件扩展名 Public Property Get FileExt() As String FileExt = parseext() End Property'获得文件目录 Public Property Get Directory() As String Directory = ParseDir() End Property'获得文件日期 Public Property Get FileDate() As Date FileDate = FileDateTime(m_FileName) End Property'解析出文件名信息 Private Function ParseFile() As StringDim N As Integer ParseFile = "" For N = Len(m_FileName) To 1 Step -1 If Mid(m_FileName, N, 1) = "\" Then ParseFile = Right(m_FileName, Len(m_FileName) - N) N = -1 End If Next NEnd Function'解析出文件目录信息 Private Function ParseDir() As StringDim N As Integer For N = Len(m_FileName) To 1 Step -1 If Mid(m_FileName, N, 1) = "\" Then ParseDir = Left(m_FileName, N) N = -1 End If Next NEnd Function'解析出文件扩展名 Private Function parseext() As StringDim N As Integer parseext = "(N/A)" For N = Len(m_FileName) To 1 Step -1 If Mid(m_FileName, N, 1) = "." Then parseext = Right(m_FileName, Len(m_FileName) - N) N = -1 End If Next N
End Function
调用，这里例子可以体现出了类的优点，如代码重用 你可以继续封装 Option Explicit'将我们的两个类声明为全局类 Dim DF1 As DiskFile Dim DF2 As DiskFile Dim Dire As String Private Sub Copy_Click()'将文件复制至根目录 Dire = InputBox("请输入想要保存文件的路径") DF1.CopyFile Dire End SubPrivate Sub DelFile_Click()'为被复制文件设置第二个类并删除文件 Dim Fildel As String Fildel = Dire & DF1.file DF2.FileName = Fildel DF2.DeleteFileEnd Sub Private Sub OpenFile_Click() '创建两个新类 Set DF1 = New DiskFile Set DF2 = New DiskFile ComDialog.Filter = "*.*" ComDialog.ShowOpen DF1.FileName = ComDialog.FileName'显示完整地文件名 FileInfo(0).Text = DF1.FileName'仅显示文件名 FileInfo(1).Text = DF1.file'显示文件扩展名 FileInfo(2).Text = DF1.FileExt'显示文件目录 FileInfo(3).Text = DF1.Directory'显示文件大小 FileInfo(4).Text = DF1.FileSize'显示文件日期 FileInfo(5).Text = DF1.FileDate'显示文件描述 DF1.FileDesc = "这是一个" & DF1.FileExt & "类型的文件" FileInfo(6).Text = DF1.FileDescEnd Sub
对特定表的数据库访问的类.Option Explicit ' 'public Message of architecture type definition 'Public req As Integer Public entry_dte As Long Public chg_dte As Long Public error_no As Long Public error_msg As String '*** 1997/07/25 T.Nomura add START******* Public ferrno As Long Public terrno As Long Public employee_no As String '*** 1997/07/25 T.Nomura add END *******Private Ds(1 To 103) As ObjectPrivate Field_1() As ObjectPrivate Field_101() As Object 'T.Nomura 1997/07/25 Private Field_102() As Object 'T.Nomura 1997/07/25 Private Field_103() As Object 'T.Nomura 1997/07/25Public Function DB_Del() As Long '*** 1997/07/25 T.Nomura add *******
DB_Ins = MyDBSQL(sqlstr) If DB_Ins = 0 Then DB_Ins = MyParaGet("rtncd") End IfEnd Function Public Function DB_Upd() As Long '*** 1997/07/25 T.Nomura add *******
DB_Upd = MyDBSQL(sqlstr) If DB_Upd = 0 Then DB_Upd = MyParaGet("rtncd") End If End Function Public Function DB_Sel() As Integer '*********************************************************/ '* */ '* Editing the Procedure and message data */ '* Parameter */ '* @error_no = Error No. */ '* @req = Request Code */ '* */ '* Specified Single data */ '* */ '*********************************************************/ Dim rtn As Integer, i As Integer ' ' req Program_Id Program_Name Write Update ' 1 96/11/20 Select Case req '*** Request Code= 1 Data extraction = Message Code ***/ '*** Specified Single data ***/ Case 1 MyDBParaSet "error_no", error_no sqlstr = "SELECT error_msg, entry_dte, chg_dte " sqlstr = sqlstr & "FROM proc_msg_master " sqlstr = sqlstr & "WHERE error_no = :error_no" rtn = MyDBDyna(Ds(req), sqlstr)
ReDim Field_1(Ds(req).Fields.Count - 1) For i = 0 To Ds(req).Fields.Count - 1 Set Field_1(i) = Ds(req).Fields(i) Next
If Rows <> 0 Then MyValRet error_msg, Field_1(0).Value MyValRet entry_dte, Field_1(1).Value MyValRet chg_dte, Field_1(2).Value End If Case 102 '1997/07/25 T.Nomura add start *********************** '***************************************************** MyDBParaSet "error_no", error_no MyDBParaSet3 "error_msg", "" MyDBParaSet "ferrno", ferrno MyDBParaSet "terrno", terrno
sqlstr = "SELECT error_no,error_msg,entry_dte,chg_dte FROM proc_msg_master " If error_no <> 0 Then sqlstr = sqlstr & " WHERE " & error_no * 100 & " <= error_no " sqlstr = sqlstr & " and error_no <= " & error_no * 100 + 99 & " " Else sqlstr = sqlstr & " WHERE " & ferrno & " <= error_no " If terrno <> 0 Then sqlstr = sqlstr & " and error_no <= " & terrno & " " End If End If sqlstr = sqlstr & " ORDER By error_no "
rtn = MyDBDyna(Ds(102), sqlstr)
ReDim Field_102(Ds(102).Fields.Count - 1) For i = 0 To Ds(102).Fields.Count - 1 Set Field_102(i) = Ds(102).Fields(i) Next i
If Rows <> 0 Then MyValRet error_no, Field_102(0).Value MyValRet error_msg, Field_102(1).Value MyValRet entry_dte, Field_102(2).Value MyValRet chg_dte, Field_102(3).Value End If
sqlstr = "SELECT error_no,error_msg,entry_dte,chg_dte FROM proc_msg_master " sqlstr = sqlstr & " WHERE error_msg like :error_msg " If ferrno <> 0 Then sqlstr = sqlstr & " and " & ferrno & " <= error_no " End If If terrno <> 0 Then sqlstr = sqlstr & " and error_no <= " & terrno & " " End If sqlstr = sqlstr & " ORDER By error_no "
rtn = MyDBDyna(Ds(103), sqlstr)
ReDim Field_103(Ds(103).Fields.Count - 1) For i = 0 To Ds(103).Fields.Count - 1 Set Field_103(i) = Ds(103).Fields(i) Next i
If Rows <> 0 Then MyValRet error_no, Field_103(0).Value MyValRet error_msg, Field_103(1).Value MyValRet entry_dte, Field_103(2).Value MyValRet chg_dte, Field_103(3).Value End If
End Select
'1997/07/25 T.Nomura add end *************************
If rtn = -1403 Then rtn = NO_MORE_ROWS
DB_Sel = rtnEnd FunctionPublic Function DB_Next() As Long Dim rtn As Long '1997/07/25 T.Nomura add start *********************** '*** req = 102 '*** req = 103 '***************************************************** If req = 102 Then Ds(102).MoveNext If Ds(102).EOF <> True Then MyValRet error_no, Field_102(0).Value MyValRet error_msg, Field_102(1).Value MyValRet entry_dte, Field_102(2).Value MyValRet chg_dte, Field_102(3).Value rtn = 0 Else rtn = NO_MORE_ROWS End If End If
'****** If req = 103 Then Ds(103).MoveNext If Ds(103).EOF <> True Then MyValRet error_no, Field_103(0).Value MyValRet error_msg, Field_103(1).Value MyValRet entry_dte, Field_103(2).Value MyValRet chg_dte, Field_103(3).Value rtn = 0 Else rtn = NO_MORE_ROWS End If End If
'1997/07/22 T.Nomura add end ************************* DB_Next = rtnEnd Function
Private m_FileName As String'储存文件描述的类成员属性
Private m_FileDesc As String'类初始化文件名的时候,说明和扩展名将设为N/A
Private Sub Class_Initialize()m_FileName = "Uninitialized"
m_FileDesc = "N/A"End Sub'类的公共方法,用于将文件复制到新位置
Public Sub CopyFile(NewLocation)
FileCopy m_FileName, NewLocation + ParseFile
End Sub
'类的公共方法,用于删除程序
Public Sub DeleteFile()On Error GoTo Errorhandle
Kill m_FileName
Errorhandle:
MsgBox vbCrLf & Err.Description
Exit Sub
End Sub
'为文件描述得到和设置类成员属性
Public Property Let FileDesc(s As String)
m_FileDesc = s
End PropertyPublic Property Get FileDesc() As String
FileDesc = m_FileDesc
End Property'根据现有信息获得纯粹的文件名
'例如： c:\windows\clouds.bmp 的文件名是 clouds.bmp
Public Property Get file() As String
file = ParseFile()
End Property'为类设置和得到文件名属性
Public Property Let FileName(s As String)
m_FileName = s
End PropertyPublic Property Get FileName() As String
FileName = m_FileName
End Property'获得文件的长度
Public Property Get FileSize() As Long
FileSize = FileLen(m_FileName)
End Property'获得文件扩展名
Public Property Get FileExt() As String
FileExt = parseext()
End Property'获得文件目录
Public Property Get Directory() As String
Directory = ParseDir()
End Property'获得文件日期
Public Property Get FileDate() As Date
FileDate = FileDateTime(m_FileName)
End Property'解析出文件名信息
Private Function ParseFile() As StringDim N As Integer
ParseFile = ""
For N = Len(m_FileName) To 1 Step -1
If Mid(m_FileName, N, 1) = "\" Then
ParseFile = Right(m_FileName, Len(m_FileName) - N)
N = -1
End If
Next NEnd Function'解析出文件目录信息
Private Function ParseDir() As StringDim N As Integer
For N = Len(m_FileName) To 1 Step -1
If Mid(m_FileName, N, 1) = "\" Then
ParseDir = Left(m_FileName, N)
N = -1
End If
Next NEnd Function'解析出文件扩展名
Private Function parseext() As StringDim N As Integer
parseext = "(N/A)"
For N = Len(m_FileName) To 1 Step -1
If Mid(m_FileName, N, 1) = "." Then
parseext = Right(m_FileName, Len(m_FileName) - N)
N = -1
End If
Next N
End Function
你可以继续封装
Option Explicit'将我们的两个类声明为全局类
Dim DF1 As DiskFile
Dim DF2 As DiskFile
Dim Dire As String
Private Sub Copy_Click()'将文件复制至根目录
Dire = InputBox("请输入想要保存文件的路径")
DF1.CopyFile Dire
End SubPrivate Sub DelFile_Click()'为被复制文件设置第二个类并删除文件
Dim Fildel As String
Fildel = Dire & DF1.file
DF2.FileName = Fildel
DF2.DeleteFileEnd Sub
Private Sub OpenFile_Click()
'创建两个新类
Set DF1 = New DiskFile
Set DF2 = New DiskFile
ComDialog.Filter = "*.*"
ComDialog.ShowOpen
DF1.FileName = ComDialog.FileName'显示完整地文件名
FileInfo(0).Text = DF1.FileName'仅显示文件名
FileInfo(1).Text = DF1.file'显示文件扩展名
FileInfo(2).Text = DF1.FileExt'显示文件目录
FileInfo(3).Text = DF1.Directory'显示文件大小
FileInfo(4).Text = DF1.FileSize'显示文件日期
FileInfo(5).Text = DF1.FileDate'显示文件描述
DF1.FileDesc = "这是一个" & DF1.FileExt & "类型的文件"
FileInfo(6).Text = DF1.FileDescEnd Sub
'
'public Message of architecture type definition
'Public req As Integer
Public entry_dte As Long
Public chg_dte As Long
Public error_no As Long
Public error_msg As String
'*** 1997/07/25 T.Nomura add START*******
Public ferrno As Long
Public terrno As Long
Public employee_no As String
'*** 1997/07/25 T.Nomura add END *******Private Ds(1 To 103) As ObjectPrivate Field_1() As ObjectPrivate Field_101() As Object 'T.Nomura 1997/07/25
Private Field_102() As Object 'T.Nomura 1997/07/25
Private Field_103() As Object 'T.Nomura 1997/07/25Public Function DB_Del() As Long
'*** 1997/07/25 T.Nomura add *******
MyDBParaSet "error_no", error_no
MyDBParaSet "employee_no", Trim(usr.user_id)
MyDBParaSet3 "rtncd", 0
sqlstr = "begin :rtncd := prmsg_delete("
sqlstr = sqlstr & ":error_no,:employee_no); end;"
DB_Del = MyDBSQL(sqlstr)
If DB_Del = 0 Then
DB_Del = MyParaGet("rtncd")
End IfEnd FunctionPublic Function DB_Ins() As Long
'*** 1997/07/25 T.Nomura add *******
MyDBParaSet "error_no", error_no
MyDBParaSet "error_msg", Trim(error_msg)
MyDBParaSet "employee_no", Trim(usr.user_id)
MyDBParaSet3 "rtncd", 0
sqlstr = "begin :rtncd := prmsg_insert("
sqlstr = sqlstr & ":error_no,:error_msg,:employee_no); end;"
DB_Ins = MyDBSQL(sqlstr)
If DB_Ins = 0 Then
DB_Ins = MyParaGet("rtncd")
End IfEnd Function
Public Function DB_Upd() As Long
'*** 1997/07/25 T.Nomura add *******
MyDBParaSet "error_no", error_no
MyDBParaSet "error_msg", Trim(error_msg)
MyDBParaSet "employee_no", Trim(usr.user_id)
MyDBParaSet3 "rtncd", 0
sqlstr = "begin :rtncd := prmsg_update("
sqlstr = sqlstr & ":error_no,:error_msg,:employee_no); end;"
DB_Upd = MyDBSQL(sqlstr)
If DB_Upd = 0 Then
DB_Upd = MyParaGet("rtncd")
End If
End Function
Public Function DB_Sel() As Integer
'*********************************************************/
'* */
'* Editing the Procedure and message data */
'* Parameter */
'* @error_no = Error No. */
'* @req = Request Code */
'* */
'* Specified Single data */
'* */
'*********************************************************/
Dim rtn As Integer, i As Integer
'
' req Program_Id Program_Name Write Update
' 1 96/11/20 Select Case req
'*** Request Code= 1 Data extraction = Message Code ***/
'*** Specified Single data ***/
Case 1
MyDBParaSet "error_no", error_no
sqlstr = "SELECT error_msg, entry_dte, chg_dte "
sqlstr = sqlstr & "FROM proc_msg_master "
sqlstr = sqlstr & "WHERE error_no = :error_no"
rtn = MyDBDyna(Ds(req), sqlstr)
ReDim Field_1(Ds(req).Fields.Count - 1)
For i = 0 To Ds(req).Fields.Count - 1
Set Field_1(i) = Ds(req).Fields(i)
Next
If Rows <> 0 Then
MyValRet error_msg, Field_1(0).Value
MyValRet entry_dte, Field_1(1).Value
MyValRet chg_dte, Field_1(2).Value
End If Case 102
'1997/07/25 T.Nomura add start ***********************
'*****************************************************
MyDBParaSet "error_no", error_no
MyDBParaSet3 "error_msg", ""
MyDBParaSet "ferrno", ferrno
MyDBParaSet "terrno", terrno
sqlstr = "SELECT error_no,error_msg,entry_dte,chg_dte FROM proc_msg_master "
If error_no <> 0 Then
sqlstr = sqlstr & " WHERE " & error_no * 100 & " <= error_no "
sqlstr = sqlstr & " and error_no <= " & error_no * 100 + 99 & " "
Else
sqlstr = sqlstr & " WHERE " & ferrno & " <= error_no "
If terrno <> 0 Then
sqlstr = sqlstr & " and error_no <= " & terrno & " "
End If
End If
sqlstr = sqlstr & " ORDER By error_no "
rtn = MyDBDyna(Ds(102), sqlstr)
ReDim Field_102(Ds(102).Fields.Count - 1)
For i = 0 To Ds(102).Fields.Count - 1
Set Field_102(i) = Ds(102).Fields(i)
Next i
If Rows <> 0 Then
MyValRet error_no, Field_102(0).Value
MyValRet error_msg, Field_102(1).Value
MyValRet entry_dte, Field_102(2).Value
MyValRet chg_dte, Field_102(3).Value
End If
Case 103
'****
MyDBParaSet3 "error_no", "0"
MyDBParaSet "error_msg", Trim(error_msg)
MyDBParaSet "ferrno", ferrno
MyDBParaSet "terrno", terrno
sqlstr = "SELECT error_no,error_msg,entry_dte,chg_dte FROM proc_msg_master "
sqlstr = sqlstr & " WHERE error_msg like :error_msg "
If ferrno <> 0 Then
sqlstr = sqlstr & " and " & ferrno & " <= error_no "
End If
If terrno <> 0 Then
sqlstr = sqlstr & " and error_no <= " & terrno & " "
End If
sqlstr = sqlstr & " ORDER By error_no "
rtn = MyDBDyna(Ds(103), sqlstr)
ReDim Field_103(Ds(103).Fields.Count - 1)
For i = 0 To Ds(103).Fields.Count - 1
Set Field_103(i) = Ds(103).Fields(i)
Next i
If Rows <> 0 Then
MyValRet error_no, Field_103(0).Value
MyValRet error_msg, Field_103(1).Value
MyValRet entry_dte, Field_103(2).Value
MyValRet chg_dte, Field_103(3).Value
End If
End Select
'1997/07/25 T.Nomura add end *************************
If rtn = -1403 Then rtn = NO_MORE_ROWS
DB_Sel = rtnEnd FunctionPublic Function DB_Next() As Long
Dim rtn As Long
'1997/07/25 T.Nomura add start ***********************
'*** req = 102
'*** req = 103
'***************************************************** If req = 102 Then
Ds(102).MoveNext
If Ds(102).EOF <> True Then
MyValRet error_no, Field_102(0).Value
MyValRet error_msg, Field_102(1).Value
MyValRet entry_dte, Field_102(2).Value
MyValRet chg_dte, Field_102(3).Value
rtn = 0
Else
rtn = NO_MORE_ROWS
End If
End If
'****** If req = 103 Then
Ds(103).MoveNext
If Ds(103).EOF <> True Then
MyValRet error_no, Field_103(0).Value
MyValRet error_msg, Field_103(1).Value
MyValRet entry_dte, Field_103(2).Value
MyValRet chg_dte, Field_103(3).Value
rtn = 0
Else
rtn = NO_MORE_ROWS
End If
End If
'1997/07/22 T.Nomura add end ************************* DB_Next = rtnEnd Function