CoderHelper 是怎样实现添加模块信息以及函数说明信息的?
首先,你需要知道,本程序的基本思路!在添加时本程序模仿了ini的读写方式.也救生步说在代码中先定好字段位置,如:"'版权信息 " 就是一个字段.接着,以字段的基础上定位键的位置.那么"'*隶属工程:"就时一个键 后面的字符就时键的值.然后,只要编写好怎样定位.那么.就很简单了!下面是其调用模块中的代码.以下代码实现了向模块中添加信息.而操作代码窗口中的代码的代码将是我所给你的代码:
'版权信息
'隶属工程: CoderHelper
'模块名称: modMark
'模块描述:
'成员个数: 2
'代码行数: 67
'声明行数: 14
'创建时间: 2005-8-10 19:24:05(创建人:MysticBoy)
'修改时间: 2005-8-10 19:37:33(修改人:MysticBoy)
'代码说明:
'版权说明: 版权所有(c) ?-2005 Mysticsoft.
' 保留所有权
'**************************************
Option Explicit
Public Sub SetCopyRightInfs(ObjVBC As VBComponent)
Dim lc As Long
On Error Resume Next
Dim tmp1x As String
With pjtMark
.ObjVBComponent = ObjVBC
lc = .FindMark("版权信息")
If frmAddIn.cbsALSGC.Value = 1 Then .WriteKey "版权信息", "隶属工程:", MVBI.ActiveVBProject.Name, lc, 1
If frmAddIn.cbsAMKM.Value Then .WriteKey "版权信息", "模块名称:", ObjVBC.Name, lc, 2
tmp1x = .ReadKey("版权信息", "模块描述:", lc)
If tmp1x = "" Then
If frmAddIn.cbsAMKMS.Value = 1 Then .WriteKey "版权信息", "模块描述:", ObjVBC.Description, lc, 3
Else
ObjVBC.Description = tmp1x
If frmAddIn.cbsAMKMS.Value = 1 Then .WriteKey "版权信息", "模块描述:", ObjVBC.Description, lc, 3
End If
If frmAddIn.cbsDMHS.Value = 1 Then
.WriteKey "版权信息", "成员个数:", CStr(ObjVBC.CodeModule.Members.Count), lc, 4
.WriteKey "版权信息", "代码行数:", CStr(ObjVBC.CodeModule.CountOfLines), lc, 5
.WriteKey "版权信息", "声明行数:", CStr(ObjVBC.CodeModule.CountOfDeclarationLines), lc, 6
End If
If .ReadKey("版权信息", "创建时间:", lc) = "" Then
.WriteKey "版权信息", "创建时间:", CStr(Now) + "(创建人:" + UserName + ")", lc, 7
End If
.WriteKey "版权信息", "修改时间:", CStr(Now) + "(修改人:" + UserName + ")", lc, 8
If frmAddIn.cbsADMSM.Value = 1 Then
If .ReadKey("版权信息", "代码说明:", lc) = "" Then
.WriteKey "版权信息", "代码说明:", "", lc, 9
End If
End If
Dim tmptxt As String
tmptxt = frmAddIn.txtABQSM.Text
tmptxt = Replace(tmptxt, "%YEAR", CStr(Year(Now)))
tmptxt = Replace(tmptxt, "&COMPANY", GetCompanyName)
.WriteKey "版权信息", "版权说明:", tmptxt, lc, 10
.WriteKey "版权信息", " 保留所有权 ", "", lc, 11
.WriteKey "版权信息", "**********************************************", "", lc, 12
If frmAddIn.cbsDMHS.Value = 1 Then
.WriteKey "版权信息", "成员个数:", CStr(ObjVBC.CodeModule.Members.Count), lc, 4
.WriteKey "版权信息", "代码行数:", CStr(ObjVBC.CodeModule.CountOfLines), lc, 5
.WriteKey "版权信息", "声明行数:", CStr(ObjVBC.CodeModule.CountOfDeclarationLines), lc, 6
End If
WriteLine "[" + ObjVBC.Name + "]的版权信息已编辑!" + IIf(err.Number <> 0, vbNewLine + "伴随错误:" & err.Number & err.Description + vbNewLine, "") & Now
End With
End Sub
Sub SetCopyrightinfToPjt(Pjt As VBProject)
Dim n As Long
For n = 1 To Pjt.VBComponents.Count
SetCopyRightInfs Pjt.VBComponents(n)
DoEvents
Next n
WriteLine "[" + Pjt.Name + "]内的" & n & "个代码模块版权信息被编辑!" & Now
End Sub
以下代码实现了在一个代码窗口中添加其方法的说明信息.
Option Explicit
Public Sub AddMethodInfs(objCmt As VBComponent)
Dim n As Long
Dim mb As Member
Dim cm As CodeModule
Set cm = objCmt.CodeModule
On Error GoTo errH
For n = 1 To objCmt.CodeModule.Members.Count
Set mb = objCmt.CodeModule.Members(n)
If mb.Type = vbext_mt_Event Or mb.Type = vbext_mt_Method Then
If frmAddIn.cbsMethods(5).Value = 1 And cm.ProcCountLines(mb.Name, vbext_pk_Proc) < frmAddIn.udMethodMixline.Value Then
WriteLine "模块[" + cm.Parent.Name + "]的成员[" + mb.Name + "]有" & cm.ProcCountLines(mb.Name, vbext_pk_Proc) & _
"行代码,小于您限制的" & frmAddIn.udMethodMixline.Value & "行,因此不编写说明信息!", vbRed
Else
AddInfsToMethod mb, cm
WriteLine "模块[" + cm.Parent.Name + "]的成员[" + mb.Name + "]说明信息处理完成!", vbBlue
End If
End If
Next n
errH:
If err.Number <> 0 Then
WriteLine "为模块[" + cm.Parent.Name + "]进行一次性添加说明信息时出现错误:" + vbNewLine + "错误内容:" + err.Description
End If
End Sub
Public Sub AddInfsToMethod(mb As Member, cm As CodeModule)
Dim loc As Long, txtLine As String
Dim txtMark As String
On Error GoTo errH
txtLine = GetProcLine(mb, cm) '找到函数头
If IsAPI(txtLine) = True Then
WriteLine "检测到[" + mb.Name + "]是API,不建议为API编写说明信息.重要API请手动编写!", vbRed
Exit Sub
End If
pjtMark.ObjVBComponent = cm.Parent
txtMark = "成员[" + mb.Name + "]说明信息"
With pjtMark
loc = .FindMark(txtMark)
loc = IIf(loc = 0, GetMbLoc(cm, txtCode:=txtLine), loc) '找到函数头所在位置
'新加条目在这里加
'~~~~~~~~~~~~~~~~
'==================================
.WriteKey txtMark, Left("" + _
"" + _
"*****************************************", 53 + Len(mb.Name)), "", loc
If frmAddIn.cbsMethods(3).Value = 1 Then
'===============================================
Dim tm3x As String
tm3x = .ReadKey(txtMark, "功能说明:", loc)
If tm3x = "" Then
.WriteKey txtMark, "功能说明:", "", loc
End If
End If
'====================================================
If frmAddIn.cbsMethods(1).Value = 1 Then
Dim pl As String
pl = GetProcLine(mb, cm, True)
Dim xxpp1 As String
Dim xps As String
xps = GetMethodReturn(pl)
xxpp1 = .ReadKey(txtMark, xps, loc)
If Trim(xxpp1) <> "" Then
.WriteKey txtMark, xxpp1, "<在此键入说明>", loc
End If
xps = GetMethodInputs(pl)
xxpp1 = .ReadKey(txtMark, "输入参数:", loc)
If xxpp1 = "" And xps <> "" Then
.WriteKey txtMark, "输入参数:", "参数名称 说明" + GetMethodInputs(pl), loc
End If
End If
'==============================================
If frmAddIn.cbsMethods(2).Value = 1 Then
Dim tm1x As String
tm1x = .ReadKey(txtMark, "成员描述:", loc)
If tm1x = "" Then
tm1x = mb.Description
Else
mb.Description = tm1x
End If
.WriteKey txtMark, "成员描述:", mb.Description, loc
End If
'===================================================
If frmAddIn.cbsMethods(4).Value = 1 Then
Dim tm2x As String
tm2x = .ReadKey(txtMark, "HelpCtID:", loc)
If CInt(tm2x + ".0") = 0 Then
tm2x = mb.HelpContextID
Else
mb.HelpContextID = tm2x
End If
.WriteKey txtMark, "HelpCtID:", mb.HelpContextID, loc
End If
'============================================================
If frmAddIn.cbsMethods(0).Value = 1 Then
.WriteKey txtMark, "成员类型:", GetMethodText(mb), loc
End If
'===================================================
If frmAddIn.cbsMethods(6).Value = 1 Then
.WriteKey txtMark, "代码编辑:", Now & "(" + UserName + ")", loc
End If
End With
errH:
If err.Number <> 0 Then
WriteLine "为模块[" + cm.Parent.Name + "]的成员[" + mb.Name + "]添加说明信息时出现错误:" + vbNewLine + "错误内容:" + err.Description
End If
End Sub
Public Function GetMethodReturn(txtCode As String, Optional txtWith As String = "'* ")
Dim n As Long
If InStr(txtCode, "Sub ") > 0 Then
GetMethodReturn = "函数返回:"
ElseIf InStr(txtCode, "Property Get ") > 0 Then
GetMethodReturn = "属性返回:"
End If
End Function
Function GetMethodInputs(txtCode As String, Optional txtWith As String = "'* ") As String
Dim ary() As String, xx1
Dim txt1 As String
Dim ret As String
Dim tmp1 As String
On Error GoTo errH
txt1 = Mid(txtCode, InStr(txtCode, "(") + 1)
txt1 = Mid(txt1 + " ", 1, InStr(txt1, ")") - 1)
ary = Split(txt1, ",")
'
For Each xx1 In ary
xx1 = Trim(xx1)
xx1 = Replace(xx1, "ByVal ", "")
xx1 = Replace(xx1, "ByRef ", "")
tmp1 = Left(xx1, InStr(xx1, " "))
If xx1 <> "" And tmp1 = "" Then
tmp1 = xx1
End If
If tmp1 = "Optional " Then
tmp1 = Trim(Right(xx1, Len(xx1) - Len(tmp1)))
tmp1 = Left(tmp1, InStr(tmp1, " ")) + "[此参数可选]"
End If
tmp1 = vbNewLine + txtWith + tmp1
ret = ret + tmp1
Next
errH:
GetMethodInputs = ret
End Function
Function GetMethodText(mb As Member)
Dim ret As String
On Error GoTo errH
If InStr(mb.Name, "") > 0 Then
Dim xxs() As String
xxs = Split(mb.Name, "")
ret = "对象[" + xxs(0) + "]的[" + xxs(1) + "]事件"
ElseIf mb.Type = vbext_mt_Method Then
ret = IIf((mb.Scope = vbext_Friend), "友员方法", IIf((mb.Scope = vbext_Private), "私有方法", "公有方法"))
ElseIf mb.Type = vbext_mt_Property Then
ret = IIf((mb.Scope = vbext_Friend), "友员属性", IIf((mb.Scope = vbext_Private), "私有属性", "公有属性"))
End If
errH:
GetMethodText = ret
End Function
Public Function GetMbLoc(cm As CodeModule, Optional mb As Member, Optional txtCode As String = "") As Long
Dim tmp1 As String, n1 As Long, n2 As Long
On Error GoTo errH
If txtCode = "" Then
tmp1 = GetProcLine(mb, cm)
Else
tmp1 = txtCode
End If
GetMbLoc = IIf(cm.Find(tmp1, n1, n2, n2, n2), n1, 0)
errH:
GetMbLoc = n1
End Function
Function GetProcLine(mb As Member, cm As CodeModule, Optional FullCode As Boolean = False) As String
Dim ary() As String, xx, ok As Boolean
Dim tmp1 As String, n1 As Long, n2 As Long
On Error GoTo errH
tmp1 = cm.Lines(cm.ProcStartLine(mb.Name, vbext_pk_Proc), cm.CountOfLines)
ary = Split(tmp1, vbNewLine)
ok = False
Dim txtmp As String
For Each xx In ary
If ok = False Then
If InStr(xx, "Sub ") > 0 Or InStr(xx, "Function ") > 0 Or InStr(xx, "Property ") > 0 Then
If InStr(xx, mb.Name) > 0 Then
If Right(Trim(xx), 1) = "" And FullCode = True Then '
ok = True
txtmp = Left(xx, InStr(xx, "") - 1)
Else
GetProcLine = xx
Exit Function
End If
End If
End If
Else
If Right(Trim(xx), 1) = "" Then
ok = True
txtmp = txtmp + Left(xx, InStr(xx, "") - 1)
Else
txtmp = txtmp + xx
GetProcLine = txtmp
Exit Function
End If
End If
Next xx
errH:
End Function
Public Function IsAPI(mbCode As String) As Boolean
'Print IsAPI("Private Declare Function GetVersionEx Lib ""kernel32"" Alias ""GetVersionExA"" (lpVersionInformation As OSVERSIONINFO) As Long")
'True
On Error Resume Next
IsAPI = InStr(mbCode, "Declare ") > 0 And InStr(mbCode, " Lib ") > 0
End Function
INI中有写键的函数,也就有读键的代码.以下是全部代码.您可以做以参考.注意:以下代码是经过调试合格的代码.无须修改即可使用.此代码仅仅在你编写向代码中添加代码的注释信息的程序时使用.代码的调用效率要求非常高的.如果你的读写一个字段.建议在可选参数中直接给字段位置lngLocMark 给你值,这样程序就不再重复调用查找字段的代码.
Option Explicit
Public ObjVBC As VBComponent
Public Sub WriteKey(txtMark As String, txtKey As String, txtValue As String, Optional lngLocMark As Long = 0, Optional KeyIndex As Long = -1)
Dim lc As Long
On Error GoTo errH
Dim txtText As String
txtText = txtValue
Dim lcx As Long
Dim xx1 As Long, xx2 As Long
xx1 = FindMark(txtMark)
lc = IIf(lngLocMark = 0, xx1, lngLocMark)
If lc = 0 Or xx1 = 0 Then
lc = IIf(lc = 0, 1, lc)
ObjVBC.CodeModule.InsertLines lc, "'" + txtMark + ""
DoEvents
End If
If KeyIndex <= 0 Then
lcx = FindKey(txtMark, txtKey, lc)
Else
If Left(ObjVBC.CodeModule.Lines(lc + KeyIndex, 1), 2) = "'" Then
lcx = KeyIndex
Else
lcx = FindKey(txtMark, txtKey, lc)
End If
End If
If lcx = 0 Then
KeyIndex = IIf(KeyIndex = -1 Or KeyIndex = 0, 1, KeyIndex)
ObjVBC.CodeModule.InsertLines lc + KeyIndex, "'" + txtKey + " " + txtValue
Exit Sub
DoEvents
lcx = KeyIndex
End If
Dim xxc As Long
xxc = FindKey(txtMark, txtKey, lc + lcx - 1)
If xxc = 0 Then
lcx = lcx
Else
lcx = xxc
End If
DoEvents
ObjVBC.CodeModule.ReplaceLine lcx, "'*" + txtKey + " " + txtValue
DoEvents
errH:
If err.Number <> 0 Then
End If
End Sub
Public Function ReadKey(txtMark As String, txtKey As String, Optional mklc As Long = 0) As String
Dim lc As Long
If mklc = 0 Then
lc = FindMark(txtMark)
Else
lc = mklc
End If
If lc > 0 Then
lc = FindKey(txtMark, txtKey, lc)
If lc > 0 Then
ReadKey = Trim(Mid(ObjVBC.CodeModule.Lines(lc, 1), Len(txtKey) + 3))
End If
End If
End Function
Public Function KillKey(txtMark, txtKey As String)
ObjVBC.CodeModule.DeleteLines FindKey(txtMark, txtKey), 1
End Function
Public Function KillMark(txtMark As String)
ObjVBC.CodeModule.DeleteLines FindMark(txtMark), 1
End Function
Public Function FindKey(ByVal txtMark As String, txtKey As String, Optional locMark As Long = 0) As Long
Dim n As Long
Dim lc As String
If locMark = 0 Then
lc = FindMark(txtMark)
Else
lc = locMark
End If
Dim txt As String
Do
lc = lc + 1
DoEvents
txt = Trim(ObjVBC.CodeModule.Lines(lc, 1))
If Left(txt, Len(txtKey) + 2) = Trim("'" + txtKey) Then
FindKey = lc
Exit Function
End If
DoEvents
Loop Until Left(txt, 2) <> "'"
'FindKey
End Function
Public Function FindMark(ByVal txtMark As String) As Long
Dim n As Long
On Error Resume Next
txtMark = "'" + txtMark + ""
Dim nx As Long, nx1 As Long, nx2 As Long
ObjVBC.CodeModule.Find txtMark, n, nx, nx1, nx2
FindMark = n
End Function
Public Property Get ObjVBComponent() As VBComponent
Set ObjVBComponent = ObjVBC
End Property
Public Property Let ObjVBComponent(ByVal vNewValue As VBComponent)
Set ObjVBC = vNewValue
End Property