本来我把这篇文章发表在BLOG上，但是发现格式全乱了，找了半天也没有发现解决办法，所以在这里把代码介绍给大家，希望各位多提宝贵意见。
另外，也请大家告诉我怎样在BLOG上发表文章，谢谢啦。BLOG的链接http://dev.csdn.net/develop/article/68/68613.shtm
4. 代码
其中函数ParseToArray是从PFC中移植过来的，在字符处理上很有用，我在EXCEL里经常用。
'------------------------------------------------------------------------------
'FILE DESCRIPTION: 新建宏文件
'------------------------------------------------------------------------------
Sub AddFunDescription()
'DESCRIPTION: 为选中的函数增加注释块
dim text, funHeader, funParms, docTab, Author
dim strFunName, strFunType
dim tmp(), strParms()
dim FunName, RetrunType, Parameters, History
docTab = 4 '制表符大小，本程序中用来对齐参数列表
Author = "Jason" '本人的英文名，请改成您的大名 ' desc控制注释块格式，修改desc可以把注释块改变成自己需要的格式。
' 修改后注意修改desc的上边界，同时后续的4个参数也要作相应的修改
dim desc(15)
desc(0) = "/******************************************************************************"
desc(1) = "" '空行
desc(2) = " FUNCTION:" + vbTab '此处将添加函数名
desc(3) = ""
desc(4) = " PURPOSE:" + vbTab
desc(5) = ""
desc(6) = " PARAMETERS:"
desc(7) = vbTab + vbTab '此处将添加参数列表
desc(8) = ""
desc(9) = " RETURN TYPE: " '此处将添加函数类型
desc(10) = vbTab + vbTab
desc(11) = " COMMENTS:" + vbTab
desc(12) = ""
desc(13) = " HISTORY:" + vbTab + "Date" + vbTab + vbTab + "Author" + vbTab + vbTab + "Comment"
desc(14) = vbTab + vbTab
desc(15) = "******************************************************************************/" FunName = 2 '放置函数名的行
RetrunType = 9 '放置函数类型的行
Parameters = 7 '放置参数列表的起始行
History = 14 '放置History的行 With ActiveDocument.Selection
' Get function info
text = trim(.text)
if text = "" then exit sub ReplaceAll text, vbTab, " "
if GetStringBetween(text, "", "(") = "" then exit sub ParseToArray GetStringBetween(text, "", "("), " ", tmp, TRUE
if UBound(tmp) = 0 then exit sub
strFunName = tmp(UBound(tmp))
For i=0 to UBound(tmp) - 1
strFunType = strFunType + tmp(i) + " "
Next ParseToArray GetStringBetween(text, "(", ")"), ",", strParms, TRUE .StartOfLine
.NewLine
.LineUp
.Text = desc(0) for line = 1 to UBound(desc)
.NewLine
.StartOfLine
if line = FunName then
.text = desc(line) + strFunName
elseif line = RetrunType then
.text = desc(line) + strFunType
elseif line = Parameters then
dim MaxLen, MaxTab
for i = 0 to UBound(strParms)
strParms(i) = Trim(strParms(i))
if MaxLen < len(strParms(i)) then
MaxLen = len(strParms(i))
end if
next MaxTab = MaxLen \ docTab for i=0 to UBound(strParms) - 1
.text = desc(line) + strParms(i) + string(MaxTab - (len(strParms(i)) \ docTab), vbTab) + vbTab + "- "
.NewLine
.StartOfLine dsFirstColumn
next
.text = desc(line) + strParms(i) + string(MaxTab - (len(strParms(i))\docTab), vbTab) + vbTab + "- "
elseif line = History then
.text = desc(line)
.text = FormatDatetime(Date, vbShortDate)
.text = + vbTab + vbTab + Author + vbTab + vbTab + "Created"
else
.text = desc(line)
end if
next End WithEnd SubSub Comment()
'DESCRIPTION: 注释选中的代码行
dim top, bottom, line
dim startCol, col
startCol = 1000 With ActiveDocument.Selection top = .TopLine
bottom = .BottomLine for line = top to bottom
.GoToLine line, dsSelect
.SelectLine
.ReplaceText "/*", "/&*"
.ReplaceText "*/", "*&/" .StartOfLine dsFirstText
col = .CurrentColumn
if startCol > col then
startCol = col
end if
next
for line = top to bottom
.MoveTo line, startCol
'MsgBox .text
.Text = "// "
next end with
End SubSub ReComment()
'DESCRIPTION: 取消选中代码行的注释
dim top, bottom, line
dim startCol, col With ActiveDocument.Selection top = .TopLine
bottom = .BottomLine for line = top to bottom
.GoToLine line, dsSelect
.SelectLine
.ReplaceText "/&*", "/*"
.ReplaceText "*&/", "*/" .StartOfLine dsFirstText
.SelectLine
pos = InStr(.text, "//")
if pos > 0 then
.Cancel
.StartOfLine dsFirstText
.Delete 2
.CharRight dsExtend
if .Text = " " then
.Delete
end if
end if
next End With
end Sub'
' 函数
'Function ParseToArray(ByVal as_source, ByVal as_delimiter, as_array(), bPreventRepeat) Dim ll_DelLen, ll_Pos, ll_Count, ll_Start, ll_Length
Dim ls_holder 'Check for NULL
If IsNull(as_source) Or IsNull(as_delimiter) Then
ParseToArray = Null
End If 'Check for at leat one entry
If Trim(as_source) = "" Then
ParseToArray = 0
End If 'Get the length of the delimeter
ll_DelLen = Len(as_delimiter) ll_Pos = InStr(UCase(as_source), UCase(as_delimiter)) 'Only one entry was found
If ll_Pos = 0 Then
ReDim as_array(0)
as_array(0) = as_source
ParseToArray = 1
End If 'More than one entry was found - loop to get all of them
ll_Count = -1
ll_Start = 1
Do While ll_Pos > 0
'Set current entry
ll_Length = ll_Pos - ll_Start
If Not bPreventRepeat Or ll_Length > 0 Then
ls_holder = Mid(as_source, ll_Start, ll_Length)
' Update array and counter
ll_Count = ll_Count + 1
ReDim Preserve as_array(ll_Count)
as_array(ll_Count) = ls_holder
Else
End If
'Set the new starting position
ll_Start = ll_Pos + ll_DelLen ll_Pos = InStr(ll_Start, UCase(as_source), UCase(as_delimiter))
Loop 'Set last entry
ls_holder = Mid(as_source, ll_Start, Len(as_source)) ' Update array and counter if necessary
If Len(ls_holder) > 0 Then
ll_Count = ll_Count + 1
ReDim Preserve as_array(ll_Count)
as_array(ll_Count) = ls_holder
End If 'parsetoarray = the number of entries found
ParseToArray = ll_CountEnd FunctionFunction GetStringBetween(ByVal str, ByVal strStart, ByVal strEnd)
Dim pos1, pos2, pos If str = "" then
GetStringBetween = ""
Exit Function
End If If strStart = "" then
pos1 = 1
Else
pos1 = InStr(str, strStart) + len(strStart)
End If pos = InStr(pos1, str, strEnd)
if pos > 0 then
Do While pos > 0
pos2 = pos
pos = InStr(pos + 1, str, strEnd)
Loop
Else
pos2 = len(str)
End If GetStringBetween = Mid(str, pos1, pos2 - pos1)
End FunctionFunction ReplaceAll(str, rep, repWith)
do while InStr(str, rep) > 0
str = Replace(str, rep, repWith)
loop
End Function
另外，也请大家告诉我怎样在BLOG上发表文章，谢谢啦。BLOG的链接http://dev.csdn.net/develop/article/68/68613.shtm
4. 代码
其中函数ParseToArray是从PFC中移植过来的，在字符处理上很有用，我在EXCEL里经常用。
'------------------------------------------------------------------------------
'FILE DESCRIPTION: 新建宏文件
'------------------------------------------------------------------------------
Sub AddFunDescription()
'DESCRIPTION: 为选中的函数增加注释块
dim text, funHeader, funParms, docTab, Author
dim strFunName, strFunType
dim tmp(), strParms()
dim FunName, RetrunType, Parameters, History
docTab = 4 '制表符大小，本程序中用来对齐参数列表
Author = "Jason" '本人的英文名，请改成您的大名 ' desc控制注释块格式，修改desc可以把注释块改变成自己需要的格式。
' 修改后注意修改desc的上边界，同时后续的4个参数也要作相应的修改
dim desc(15)
desc(0) = "/******************************************************************************"
desc(1) = "" '空行
desc(2) = " FUNCTION:" + vbTab '此处将添加函数名
desc(3) = ""
desc(4) = " PURPOSE:" + vbTab
desc(5) = ""
desc(6) = " PARAMETERS:"
desc(7) = vbTab + vbTab '此处将添加参数列表
desc(8) = ""
desc(9) = " RETURN TYPE: " '此处将添加函数类型
desc(10) = vbTab + vbTab
desc(11) = " COMMENTS:" + vbTab
desc(12) = ""
desc(13) = " HISTORY:" + vbTab + "Date" + vbTab + vbTab + "Author" + vbTab + vbTab + "Comment"
desc(14) = vbTab + vbTab
desc(15) = "******************************************************************************/" FunName = 2 '放置函数名的行
RetrunType = 9 '放置函数类型的行
Parameters = 7 '放置参数列表的起始行
History = 14 '放置History的行 With ActiveDocument.Selection
' Get function info
text = trim(.text)
if text = "" then exit sub ReplaceAll text, vbTab, " "
if GetStringBetween(text, "", "(") = "" then exit sub ParseToArray GetStringBetween(text, "", "("), " ", tmp, TRUE
if UBound(tmp) = 0 then exit sub
strFunName = tmp(UBound(tmp))
For i=0 to UBound(tmp) - 1
strFunType = strFunType + tmp(i) + " "
Next ParseToArray GetStringBetween(text, "(", ")"), ",", strParms, TRUE .StartOfLine
.NewLine
.LineUp
.Text = desc(0) for line = 1 to UBound(desc)
.NewLine
.StartOfLine
if line = FunName then
.text = desc(line) + strFunName
elseif line = RetrunType then
.text = desc(line) + strFunType
elseif line = Parameters then
dim MaxLen, MaxTab
for i = 0 to UBound(strParms)
strParms(i) = Trim(strParms(i))
if MaxLen < len(strParms(i)) then
MaxLen = len(strParms(i))
end if
next MaxTab = MaxLen \ docTab for i=0 to UBound(strParms) - 1
.text = desc(line) + strParms(i) + string(MaxTab - (len(strParms(i)) \ docTab), vbTab) + vbTab + "- "
.NewLine
.StartOfLine dsFirstColumn
next
.text = desc(line) + strParms(i) + string(MaxTab - (len(strParms(i))\docTab), vbTab) + vbTab + "- "
elseif line = History then
.text = desc(line)
.text = FormatDatetime(Date, vbShortDate)
.text = + vbTab + vbTab + Author + vbTab + vbTab + "Created"
else
.text = desc(line)
end if
next End WithEnd SubSub Comment()
'DESCRIPTION: 注释选中的代码行
dim top, bottom, line
dim startCol, col
startCol = 1000 With ActiveDocument.Selection top = .TopLine
bottom = .BottomLine for line = top to bottom
.GoToLine line, dsSelect
.SelectLine
.ReplaceText "/*", "/&*"
.ReplaceText "*/", "*&/" .StartOfLine dsFirstText
col = .CurrentColumn
if startCol > col then
startCol = col
end if
next
for line = top to bottom
.MoveTo line, startCol
'MsgBox .text
.Text = "// "
next end with
End SubSub ReComment()
'DESCRIPTION: 取消选中代码行的注释
dim top, bottom, line
dim startCol, col With ActiveDocument.Selection top = .TopLine
bottom = .BottomLine for line = top to bottom
.GoToLine line, dsSelect
.SelectLine
.ReplaceText "/&*", "/*"
.ReplaceText "*&/", "*/" .StartOfLine dsFirstText
.SelectLine
pos = InStr(.text, "//")
if pos > 0 then
.Cancel
.StartOfLine dsFirstText
.Delete 2
.CharRight dsExtend
if .Text = " " then
.Delete
end if
end if
next End With
end Sub'
' 函数
'Function ParseToArray(ByVal as_source, ByVal as_delimiter, as_array(), bPreventRepeat) Dim ll_DelLen, ll_Pos, ll_Count, ll_Start, ll_Length
Dim ls_holder 'Check for NULL
If IsNull(as_source) Or IsNull(as_delimiter) Then
ParseToArray = Null
End If 'Check for at leat one entry
If Trim(as_source) = "" Then
ParseToArray = 0
End If 'Get the length of the delimeter
ll_DelLen = Len(as_delimiter) ll_Pos = InStr(UCase(as_source), UCase(as_delimiter)) 'Only one entry was found
If ll_Pos = 0 Then
ReDim as_array(0)
as_array(0) = as_source
ParseToArray = 1
End If 'More than one entry was found - loop to get all of them
ll_Count = -1
ll_Start = 1
Do While ll_Pos > 0
'Set current entry
ll_Length = ll_Pos - ll_Start
If Not bPreventRepeat Or ll_Length > 0 Then
ls_holder = Mid(as_source, ll_Start, ll_Length)
' Update array and counter
ll_Count = ll_Count + 1
ReDim Preserve as_array(ll_Count)
as_array(ll_Count) = ls_holder
Else
End If
'Set the new starting position
ll_Start = ll_Pos + ll_DelLen ll_Pos = InStr(ll_Start, UCase(as_source), UCase(as_delimiter))
Loop 'Set last entry
ls_holder = Mid(as_source, ll_Start, Len(as_source)) ' Update array and counter if necessary
If Len(ls_holder) > 0 Then
ll_Count = ll_Count + 1
ReDim Preserve as_array(ll_Count)
as_array(ll_Count) = ls_holder
End If 'parsetoarray = the number of entries found
ParseToArray = ll_CountEnd FunctionFunction GetStringBetween(ByVal str, ByVal strStart, ByVal strEnd)
Dim pos1, pos2, pos If str = "" then
GetStringBetween = ""
Exit Function
End If If strStart = "" then
pos1 = 1
Else
pos1 = InStr(str, strStart) + len(strStart)
End If pos = InStr(pos1, str, strEnd)
if pos > 0 then
Do While pos > 0
pos2 = pos
pos = InStr(pos + 1, str, strEnd)
Loop
Else
pos2 = len(str)
End If GetStringBetween = Mid(str, pos1, pos2 - pos1)
End FunctionFunction ReplaceAll(str, rep, repWith)
do while InStr(str, rep) > 0
str = Replace(str, rep, repWith)
loop
End Function
doxgen也有类似的东西，也比较好用
http://www.winmsg.com/cn/orbit.htm