转自：http://topic.csdn.net/t/20050419/23/3950499.html

本来我把这篇文章发表在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 With End Sub Sub 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 Sub

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

End Function

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

Function ReplaceAll(str, rep, repWith)
do while InStr(str, rep) > 0
str = Replace(str, rep, repWith)
loop
End Function