CoderHelper 是怎样实现添加模块信息以及函数说明信息的?

首先,你需要知道,本程序的基本思路!在添加时本程序模仿了ini的读写方式.也救生步说在代码中先定好字段位置,如:"'********************版权信息********************" 就是一个字段.接着,以字段的基础上定位键的位置.那么"'*隶属工程:"就时一个键后面的字符就时键的值.然后,只要编写好怎样定位.那么.就很简单了!下面是其调用模块中的代码.以下代码实现了向模块中添加信息.而操作代码窗口中的代码的代码将是我所给你的代码:

'********************版权信息********************

'*隶属工程: CoderHelper

'*模块名称: modMark

'*模块描述:

'*成员个数: 2

'*代码行数: 67

'*声明行数: 14

'*创建时间: 2005-8-10 19:24:05(创建人:MysticBoy)

'*修改时间: 2005-8-10 19:37:33(修改人:MysticBoy)

'*代码说明:

'* 保留所有权

'***********************************************

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

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

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

'====================================================

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

'==============================================

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

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

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

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

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 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

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