从模块、窗体中提取常量值、公共过程、函数
时 间:2017-10-30 07:16:26
作 者:litao ID:37995 城市:上海
摘 要:模块是否有相应的资源(常量、过程、函数)
正 文:
很多时候,我们要处理一些未知的模块。比如预先写的函数,无法预料将来要应用到哪里。
这个函数执行前先检查以下,应用的模块是否有相应的资源(常量、过程、函数)
上代码:
'检查模块中,是否有相应的公共Sub/Function
Public Function ScanModuleSub(Sub_Name As String, Module As Module, Optional IsFunction As Boolean = False) As Boolean
'Sub_Name=过程/函数名
'Module=模块
'IsFunction=是否是函数。True=Function;False=Sub
ScanModuleSub = False
On Error GoTo err1
Dim SubName As String, SubTxt As String
SubName = "ScanModuleSub"
SubTxt = "检查模块中,是否有相应的公共Sub/Function"
Sub_Name = Trim(Sub_Name)
If Module Is Nothing or Sub_Name = "" Then GoTo err1
Dim i As Long, Code As String, Ftxt As String, Ftxt2 As String
Dim sz() As String
If IsFunction Then
Ftxt = "Public Function " & Sub_Name & "("
Else
Ftxt = "Public Sub " & Sub_Name & "("
End If
Ftxt = UCase(Ftxt)
Ftxt2 = Replace(Ftxt, "PUBLIC ", "") '无关键词 Public
For i = 1 To Module.CountOfLines '逐行读取
Code = Module.Lines(i, 1)
'Debug.Print i & "# " & Code
Code = Trim(Code)
If Code = "" or Left(Code, 1) = "'" Then GoTo Next1 '跳过注释语句
sz = Split(Code, "'")
Code = Trim(sz(0)) '剔除 注释
Code = UCase(Left(Code, Len(Ftxt)))
If Code = Ftxt or Left(Code, Len(Ftxt2)) = Ftxt2 Then
ScanModuleSub = True
Exit Function
End If
Next1:
Next
Exit Function
err1:
Call ErrMsBox(SubName, SubTxt & " 失败!")
End Function
'提取模块中所有公共Sub/Function词典
Public Function PublicSubDic(Module As Module) As Scripting.Dictionary
'Module=模块
Set PublicSubDic = Nothing
On Error GoTo err1
Dim SubName As String, SubTxt As String
SubName = "PublicSubDic"
SubTxt = "提取模块中所有公共Sub/Function词典"
If Module Is Nothing Then GoTo err1
Dim Dic As New Scripting.Dictionary
Dic.CompareMode = 1 'TextCompare 文本比较 不区分大小写
Dim i As Long, Code As String, Txt0 As String, Txt1 As String
Dim RowTxt As String, Name As String, ParamS As String, Retun As String, Typ As String
Dim sz() As String, sz1() As String
For i = 1 To Module.CountOfLines '逐行读取
Code = Module.Lines(i, 1)
'Debug.Print i & "# " & Code
Code = Trim(Code)
If Code = "" or Left(Code, 1) = "'" Then GoTo Next1 '跳过 注释行
sz = Split(Code, "'")
RowTxt = Trim(sz(0)) '剔除注释,获取有效行字符
sz1 = Split(RowTxt, "(")
Txt0 = Trim(sz1(0)) '名称部分
If InStr(Txt0, "Sub ") > 0 Then
sz = Split(Txt0, "Sub ")
Typ = "Sub" '类型
ElseIf InStr(Txt0, "Function ") > 0 Then
sz = Split(Txt0, "Function ")
Typ = "Function" '类型
Else
GoTo Next1 '跳过 没有Sub/Function的语句
End If
Txt1 = Trim(sz(0)) '访问限制
Name = Trim(sz(1)) '名称
If InStr(Txt1, "Private") > 0 Then GoTo Next1 '跳过 私有
If UBound(sz1) >= 1 Then '参数部分
'分解参数
sz = Split(sz1(1), ")")
ParamS = Trim(sz(0)) '参数串
If UBound(sz) >= 1 Then '返回部分
Retun = Replace(sz(1), "As", "")
Retun = Trim(Retun)
Else
Retun = ""
End If
Else
ParamS = ""
Retun = ""
End If
Dim dc As New Scripting.Dictionary
dc("Name") = Name '名称
dc("RowTxt") = RowTxt '行字符
dc("Type") = Typ '类型
dc("ParamS") = ParamS '参数串
dc("Return") = Retun '返回
Set Dic(Name) = dc
Next1:
Next
Set PublicSubDic = Dic
Exit Function
err1:
Call ErrMsBox(SubName, SubTxt & " 失败!")
End Function
'从模块中读取指定常量值
Public Function GetConst(Module As Module, ConstName As String) As String
'Module=模块
'ConstName=常量名
GetConst = ""
On Error GoTo err1
Dim SubName As String, SubTxt As String
SubName = "GetConst"
SubTxt = "从模块中读取指定常量值"
If Module Is Nothing Then GoTo err1
Dim Txt1 As String, Txt2 As String
Txt1 = "MeTab = "
Txt2 = "Const MeTab "
Dim i As Long, Code As String, UCode As String
Dim sz() As String
For i = 1 To Module.CountOfLines '逐行读取
Code = Module.Lines(i, 1)
'Debug.Print i & "# " & Code
Code = Trim(Code)
If Code = "" or Left(Code, 1) = "'" Then GoTo Next1 '跳过 注释语句
sz = Split(Code, "'")
Code = Trim(sz(0)) '剔除 注释
If Code = "" Then GoTo Next1 '跳过 空语句
If InStr(1, Code, "=") <= 0 Then GoTo Next1 '跳过 非赋值语句
If InStr(1, Code, Txt1, 1) > 0 Then '忽略大小写
'Function
ElseIf InStr(1, Code, Txt2, 1) > 0 Then '忽略大小写
'Const
sz = Split(Code, ",")
Code = Trim(sz(0)) '第一个Const
Else
GoTo Next1
End If
sz = Split(Code, "=")
Code = Trim(sz(1)) '等号右侧 字符串
If InStr(1, Code, """") <= 0 Then GoTo Next1 '跳过 非"XX"语句
sz = Split(Code, """")
Code = Trim(sz(1)) '引号内 字符串
If Code <> "" Then '返回
GetConst = Code
Exit Function
End If
Next1:
Next
Exit Function
err1:
Call ErrMsBox(SubName, SubTxt & " 失败!")
End Function
Access软件网官方交流QQ群 (群号:54525238) Access源码网店
常见问答:
技术分类:
源码示例
- 【源码QQ群号19834647...(12.17)
- 【Access选项卡示例】Ac...(09.09)
- 【Access源码示例】按输入...(09.02)
- 【Access日期区间段查询】...(08.29)
- 【Access日期区间段查询】...(08.27)
- Access怎样才能实现日期时...(08.21)
- 【Access定时打开查询】A...(08.19)
- Access生成固定数量的记录...(08.13)
- Access怎样才能实现日期时...(08.12)
- Access利用导航窗体控件对...(08.03)
学习心得
最新文章
- Access表中的字段名、字段标题...(09.19)
- Access快速开发平台--更改“...(09.18)
- 【中秋及国庆优惠】Access培训...(09.15)
- Access如何将日期型的数值转换...(09.14)
- 英文输入法输入数据中存在单引号引起...(09.11)
- 【Access选项卡示例】Acce...(09.09)
- 让Access光标停留在指定的控件...(09.07)
- 关于Access查询条件里使用通配...(09.06)
- Access报表偷懒制作法--Ac...(09.05)
- Access快速开发平台--窗体数...(09.04)