从模块、窗体中提取常量值、公共过程、函数
时 间: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对子窗体数据进行批...(10.30)
- 最精简的组合框行来源数据快速输...(10.25)
- Access仿平台的多值选择器...(10.24)
- 【Access日期区间段查询】...(10.22)
- 【Access源码示例】VBA...(10.12)
- Access累乘示例,Acce...(10.09)
- 数值8.88,把整数8去掉,转...(10.08)
- 【Access自定义函数】一个...(09.30)
- 【Access选项卡示例】Ac...(09.09)
学习心得
最新文章
- Access快速开发平台企业版--...(11.18)
- 不会用多表联合查询,多表查询没结果...(11.16)
- 【案例分享】主键字段值含有不间断空...(11.16)
- Access快速开发平台--后台D...(11.14)
- 微软Access邀测新Monaco...(11.12)
- Access列表框左右互选、列表框...(11.11)
- 高效率在导入数据前删除记录(11.10)
- Access报价单转订单示例代码(11.08)
- Access系统自带的日期选择器不...(11.08)
- 分享一下Access工程中的acw...(11.07)