从模块、窗体中提取常量值、公共过程、函数

时　间: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