Vba代码自动缩进功能的实现.doc

Vba代码自动缩进功能的实现喜欢Vba的朋友到知道:编写宏代码时,如果代码一多,就觉得杂乱无章,没有条理性.如何进行代码自动缩进,就成了紧迫的问题.下面就介绍实现此功能的DLL文件的编译过程:一. 编译环境:vb6.0,office2000,Excel2000二. 编译步骤:(一)把下面代码保存为Connect.Dsr文件:1. VERSION 5.002. Begin AC0714F6-3D04-11D1-AE7D-00A0C90F26F4 Connect 3. ClientHeight = 63004. ClientLeft = 17405. ClientTop = 15456. ClientWidth = 111307. _ExtentX = 196328. _ExtentY = 111139. _Version = 39321610. Description = Add-In Project Template11. DisplayName = My Add-In12. AppName = Microsoft Excel13. AppVer = Microsoft Excel 9.014. LoadName = Startup15. LoadBehavior = 316. RegLocation = HKEY_CURRENT_USERSoftwareMicrosoftOfficeExcel17. End18. Attribute VB_Name = Connect19. Attribute VB_GlobalNameSpace = False20. Attribute VB_Creatable = True21. Attribute VB_PredeclaredId = False22. Attribute VB_Exposed = True23. Option Explicit24.25. Private WithEvents sj1 As Office.CommandBarButton26. Attribute sj1.VB_VarHelpID = -127.28. Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)29. On Error Resume Next30. Set xlapp = Application31. =在工具栏创建试验按钮1=32. xlapp.CommandBars(tools).Controls(代码缩进).Delete33. Set sj1 = xlapp.CommandBars(tools).Controls.Add(Type:=msoControlButton)34. With sj135. .Caption = 代码缩进36. .Style = msoButtonIconAndCaption37. End With38. End Sub39.40. Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode _41. As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)42. On Error Resume Next43. AddinInstance_Terminate44. End Sub45.46. Private Sub AddinInstance_Terminate()47. On Error Resume Next48. xlapp.CommandBars(tools).Controls(代码缩进).Delete49. Set xlapp = Nothing50. End Sub51.52. Private Sub sj1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)53. IndentCode54. End Sub(二) 把下面代码保存为ModIndentCode.bas文件:1. Attribute VB_Name = ModIndentCode2. Option Explicit3.4. Public Const m_iErrMsg As Integer = vbAbortRetryIgnore + vbCritical5. Public Sj As Byte, sjCfg() As Byte, DefMenuName As String, DefMenuCaption As String 参数变量：sj=每行缩进的空格数*6. Public UndoCs As Integer 撤消次数7. Public xlapp As Object8.9. Sub IndentCode()10. Dim mCode, FuncName As String, i As Long11. Dim objMember12. Dim Line1 As Long, Line2 As Long, Line3 As Long, Line4 As Long, DeclarLines As Long13. Dim s As String, S1 As String14. ReadCfg15. On Error GoTo 116. Set mCode = xlapp.ActiveWorkbook.VBProject.VBComponents17. For i = 1 To mCode.Count18. Set objMember = mCode(i).CodeModule19. DeclarLines = objMember.CountOfDeclarationLines20. Line1 = 1 过程的起始行21. Line2 = objMember.CountOfLines 过程的总行数22. If Line2 0 Then23. S1 = IndentCode1(objMember, Line1, Line1 + Line2 - 1) & vbNewLine24. objMember.DeleteLines Line1, Line225. objMember.InsertLines 1, S126. objMember.ReplaceLine Line1, S127. mCode.AddFromString S128. MsgBox S129. Exit For30. End If31. Next32. MsgBox 代码自动缩进已完成!, , 提示33. Exit Sub34. 1:35. MsgBox 错误号: & Err.Number & vbNewLine & 错误信息: & Err.Description, vbCritical, 出错提示36. End Sub37.38. Public Function IndentCode1(ByVal mCode, Optional Line1 As Long, Optional Line2 As Long)39. Dim nIndent As Integer40. Dim nLine As Long41. Dim strNewLine As String, strNewLine1 As String, OldLine As String, SrcDm As String42. Dim s As String, S1 As String, i As Integer43. Dim a() As String, kh As Long44.45. 对入口参数进行处理46. Select Case TypeName(mCode)47. Case CodeModule48. If Line1 1 Then Line1 = 149. If Line2 Line1 Then Line2 = mCode.CountOfLines50. Case String()51. If Line1 LBound(mCode) Then Line1 = LBound(mCode)52. If Line2 Line1 Then Line2 = UBound(mCode)53. Case Else54. Exit Function55. End Select56.57. ReDim a(Line1 To Line2)58. For nLine = Line1 To Line259. 取出每行代码60. If TypeName(mCode) = CodeModule Then61. strNewLine = mCode.Lines(nLine, 1)62. Else63. strNewLine = mCode(nLine)64. End If65. SrcDm = strNewLine66. s = strNewLine67.68. 把每行代码分离成代码和注释部分69. strNewLine = SplitLine(s)70. strNewLine1 = Mid(s, Len(strNewLine) + 1) 注释71. strNewLine = Trim(strNewLine) 代码72. If strNewLine And strNewLine1 Then strNewLine1 = Space$(Sj) & strNewLine173. If sjCfg(2) = 1 Then strNewLine1 = 删除注释*74.75. If nLine Line1 Then76. 删除双行空白行*77. If sjCfg(3) = 1 And sjCfg(4) = 0 And LTrim(strNewLine) = And strNewLine1 = And a(nLine - kh - 1) = Then78. kh = kh + 179. End If80. If sjCfg(4) = 1 And LTrim(strNewLine) = And strNewLine1 = Then81. kh = kh + 1 删除全部空白行*82. GoTo 183. End If84. End If85.86. 进行缩放处理,把结果存放到数组中87. If IsBlockEnd(strNewLine) Then nIndent = nIndent - 1 关键字结束，下行减少一个缩进单位88. If nIndent 0 Then nIndent = 089. Put back new line.90. If InStr(OldLine, _) = 0 Then 正常行91. a(nLine - kh) = IIf(strNewLine & strNewLine1 = , , Space$(nIndent * Sj) & strNewLine & strNewLine1)92. If strNewLine = And strNewLine1 And sjCfg(1) = 0 Then a(nLine - kh) = SrcDm 注释缩进*93. OldLine = IIf(strNewLine = , , Space$(nIndent * Sj) & strNewLine) 保存当前行(为判断折行做准备)94. Else 折行95. S1 = LTrim(OldLine)96. i = InStr(S1, )97. a(nLine - kh) = Space$(Len(OldLine) - Len(S1) + i) & strNewLine & strNewLine198. If InStr(strNewLine, _) = 0 Then OldLine = 99. End If100. i = IsBlockStart(strNewLine)101. If i 0 Then102. nIndent = nIndent + 1 关键字开始，下行增加一个缩进单位103. If i = 2 Then 在程序中缩进*104. a(nLine - kh) = LTrim(a(nLine - kh)105. If a(nLine - kh) And sjCfg(5) = 1 And sjCfg(4) = 0 Then 过程函数名称前加一空行*106. S1 = 1107. If nLine - kh 1 Then S1 = Trim(a(nLine - kh - 1): If Left(S1, 1) = Then S1 = 108. If Len(S1) 0 Then a(nLine - kh) = vbNewLine & a(nLine - kh)109. End If110. nIndent = 1111. End If112. End If113. 1:114. Next115.116. 把数组一次性更新到模块中117. i = Line2 - kh118. ReDim Preserve a(Line1 To i)119. S1 = Join(a, vbNewLine)120.121. If a(Line1) And Line1 1 And sjCfg(5) = 1 And sjCfg(4) = 0 Then 过程函数名称前加一空行*122. S1 = vbNewLine & S1123. End If124. If Right(S1, 4) = vbNewLine & vbNewLine Then S1 = Left(S1, Len(S1) - 2)125. IndentCode1 = S1126. End Function127.128. Private Function IsBlockStart(strLine As String) As Integer129. Dim nPos As Integer130. Dim strTemp As String131. Dim Head As Integer 函数头标识132.133. strLine = LTrim(strLine)134. nPos = InStr(1, strLine, ) - 1135. If nPos 0 Then Head = 1146. Case Private, Public, Friend147. nPos = InStr(1, strLine, Static )148. If nPos Then149. nPos = InStr(nPos + 7, strLine, )150. Else151. nPos = InStr(Len(strTemp) + 1, strLine, )152. End If153. Select Case Mid$(strLine, nPos + 1, InStr(nPos + 1, strLine, ) - nPos - 1)154. Case Sub, Function, Property155. Head = 2156. Case Enum, Type157. Head = 1158. End Select159. End Select160.161. IsBlockStart = Head162. End Function163.164. Private Function IsBlockEnd(strLine As String) As Boolean165. Dim bOK As Boolean166. Dim nPos As Integer167. Dim strTemp As String168.169. strLine = LTrim(strLine)170. nPos = InStr(1, strLine, ) - 1171. If nPos 3)180. End Select181. IsBlockEnd = bOK182. End Function183.184. Public Function HandleError() As VbMsgBoxResult185. HandleError = MsgBox(代码 & Err.Source & 错误： & vbCrLf & 详细： & Err.Description _186. & vbCrLf & 错误号： & Err.Number, m_iErrMsg, App.Title)187. End Function188.189. Function HasCodeModule(VBComp) As Boolean190. On Error GoTo ErrHandler191.192. Select Case VBComp.Type193. Case vbext_ct_ActiveXDesigner194. HasCodeModule = True195. Case vbext_ct_ClassModule196. HasCodeModule = True197. Case vbext_ct_DocObject198. HasCodeModule = False199. Case vbext_ct_MSForm200. HasCodeModule = True201. Case vbext_ct_PropPage202. HasCodeModule = True203. Case vbext_ct_RelatedDocument204. HasCodeModule = False205. Case vbext_ct_ResFile206. HasCodeModule = False207. Case vbext_ct_StdModule208. HasCodeModule = True209. Case vbext_ct_UserControl210. HasCodeModule = True211. Case vbext_ct_VBForm212. HasCodeModule = True213. Case vbext_ct_VBMDIForm214. HasCodeModule = True215. Case Else216. HasCodeModule = False217. End Select218.219. ExitProc:220. Exit Function221. ErrHandler:222. Err.Raise Err.Number, (HasCodeModule: & VBA.Erl & ) & Err.Source, Err.Description223. End Function224.225.226. 获取命令行的主体部分227. Function SplitLine(ByVal CmdLine As String) As String228. Dim i As Integer, j As Integer, K As Integer, m As Integer, n As Integer, s As String, S1 As String229. Dim Resu As String230. If Trim(CmdLine) = Then SplitLine = CmdLine: Exit Function231. 1:232. i = InStr(CmdLine, )233. If i Then234. j = InStrRev(CmdLine, Chr(34), i, vbTextCompare)235. If j Then236. K = 0237. Do While j 0238. If j 1 Then239. j = InStrRev(CmdLine, Chr(34), j - 1, vbTextCompare)240. Else241. j = 0242. End If243. K = K + 1244. Loop245. If K Mod 2 = 0 Then 号前有偶数号246. Resu = Resu & Left(CmdLine, i - 1)247. Else 号前有奇数号248. i = InStr(i, CmdLine, Chr(34), vbTextCompare)249. Resu = Resu & Left(CmdLine, i)250. CmdLine = Mid(CmdLine, i + 1)251. GoTo 1252. End If253. Else 有号但没有号254. Resu = Resu & Left(CmdLine, i - 1)255. End If256. Else 没有号257. Resu = Resu & CmdLine258. End If259.260. SplitLine = Resu261. End Function262.263. Sub ReadCfg() 读取缩进参数264. Dim s As String, i As Integer, a() As String265. ReDim sjCfg(5)266. DefMenuName = Trim(GetSetting(DllAddin, config, DefMenuName)267. DefMenuCaption = Trim(GetSetting(DllAddin, config, DefMenuCaption)268. If DefMenuCaption = Then DefMenuCaption = GetFileName(DefMenuName)269. s = GetSetting(DllAddin, config, cs)270. a = Split(s, ,)271. If UBound(a) UBound(sjCfg) + 1 Then272. s = 4,1,1,0,1,0,1 默认273. a = Split(s, ,)274. End If275. Sj = Val(a(0)276. For i = 0 To UBound(sjCfg)277. sjCfg(i) = Val(a(i + 1)278. Next279. End Sub(三) 把下面代码保存为MyExcelAddin.vbp文件1. Type=OleDll2. Reference=*G2DF8D04C-5BFA-101B-BDE5-00AA0044DE52#2.0#0#C:Program FilesMicrosoft OfficeOfficeMSO9.DLL#Microsoft Office 8.0 Object Library3. Reference=*GAC0714F2-3D04-11D1-AE7D-00A0C90F26F4#1.0#0#C:Program FilesCommon FilesdesignerMSADDNDR.TLB#Add-In Designer/Instance Control Library4. Reference=*GEF404E00-EDA6-101A-8DAF-00DD010F7EBB#5.3#0#e:VB98VB6EXT.OLB#Microsoft Visual Basic 6.0 Extensibility5. Reference=*G00020813-0000-0000-C000-000000000046#1.3#0#C:Program FilesMicrosoft OfficeOffi