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

CoderHelper 是怎样实现添加模块信息以及函数说明信息的? 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

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 给你值,这样程序就不再重复调用查找字段的代码.

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