Vba代码自动缩进功能的实现
喜欢Vba的朋友到知道:编写宏代码时,如果代码一多,就觉得杂乱无章,没有条理性.如何进行代码自动缩进,就成了紧迫的问题.
下面就介绍实现此功能的DLL文件的编译过程:
一. 编译环境:vb6.0,office2000,Excel2000
二. 编译步骤:
(一)把下面代码保存为Connect.Dsr文件:
1. VERSION 5.00
2. Begin {AC0714F6-3D04-11D1-AE7D-00A0C90F26F4} Connect
3. ClientHeight = 6300
4. ClientLeft = 1740
5. ClientTop = 1545
6. ClientWidth = 11130
7. _ExtentX = 19632
8. _ExtentY = 11113
9. _Version = 393216
10. Description = \"Add-In Project Template\"
11. DisplayName = \"My Add-In\"
12. AppName = \"Microsoft Excel\"
13. AppVer = \"Microsoft Excel 9.0\"
14. LoadName = \"Startup\"
15. LoadBehavior = 3
16. RegLocation 17. End
18. Attribute VB_Name = \"Connect\"
19. Attribute VB_GlobalNameSpace = False
20. Attribute VB_Creatable = True
=
\"HKEY_CURRENT_USER\\Software\\Microsoft\\Office\\Excel\"
21. Attribute VB_PredeclaredId = False
22. Attribute VB_Exposed = True
23. Option Explicit
24. Private WithEvents sj1 As Office.CommandBarButton
25. Attribute sj1.VB_VarHelpID = -1
26. Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
27. On Error Resume Next
28. Set xlapp = Application
29. '=================================在<我的的工具>工具栏创建\"试验按钮1\"==================================
30. xlapp.CommandBars(\"tools\").Controls(\"代码缩进\").Delete
31. Set sj1 =
xlapp.CommandBars(\"tools\").Controls.Add(Type:=msoControlButton)
32. With sj1
33. .Caption = \"代码缩进\"
34. .Style = msoButtonIconAndCaption
35. End With
36. End Sub
37. Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode _
38. As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
39. On Error Resume Next
40. AddinInstance_Terminate
41. End Sub
42. Private Sub AddinInstance_Terminate()
43. On Error Resume Next
44. xlapp.CommandBars(\"tools\").Controls(\"代码缩进\").Delete
45. Set xlapp = Nothing
46. End Sub
47. Private Sub sj1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
48. IndentCode
49. End Sub
(二) 把下面代码保存为ModIndentCode.bas文件:
1. Attribute VB_Name = \"ModIndentCode\"
2. Option Explicit
3. Public Const m_iErrMsg As Integer = vbAbortRetryIgnore + vbCritical
4. Public Sj As Byte, sjCfg() As Byte, DefMenuName As String, DefMenuCaption As String '参数变量：sj=每行缩进的空格数***
5. Public UndoCs As Integer '撤消次数
6. Public xlapp As Object
7. Sub IndentCode()
8. Dim mCode, FuncName As String, i As Long
9. Dim objMember
10. Dim Line1 As Long, Line2 As Long, Line3 As Long, Line4 As Long, DeclarLines As Long
11. Dim s As String, S1 As String
12. ReadCfg
13. On Error GoTo 1
14. Set mCode = xlapp.ActiveWorkbook.VBProject.VBComponents
15. For i = 1 To mCode.Count
16. Set objMember = mCode(i).CodeModule
17. DeclarLines = objMember.CountOfDeclarationLines
18. Line1 = 1 '过程的起始行
19. Line2 = objMember.CountOfLines '过程的总行数
20. If Line2 > 0 Then
21. S1 = IndentCode1(objMember, Line1, Line1 + Line2 - 1) & vbNewLine
22. objMember.DeleteLines Line1, Line2
23. objMember.InsertLines 1, S1
24. 'objMember.ReplaceLine Line1, S1
25. 'mCode.AddFromString S1
26. 'MsgBox S1
27. 'Exit For
28. End If
29. Next
30. MsgBox \"代码自动缩进已完成!\提示\"
31. Exit Sub
32. 1:
33. MsgBox \"错误号:\" & Err.Number & vbNewLine & \"错误信息:\" & Err.Description, vbCritical, \"出错提示\"
34. End Sub
35. Public Function IndentCode1(ByVal mCode, Optional Line1 As Long, Optional Line2 As Long)
36. Dim nIndent As Integer
37. Dim nLine As Long
38. Dim strNewLine As String, strNewLine1 As String, OldLine As String, SrcDm As String
39. Dim s As String, S1 As String, i As Integer
40. Dim a() As String, kh As Long
41. '对入口参数进行处理
42. Select Case TypeName(mCode)
43. Case \"CodeModule\"
44. If Line1 < 1 Then Line1 = 1
45. If Line2 < Line1 Then Line2 = mCode.CountOfLines
46. Case \"String()\"
47. If Line1 < LBound(mCode) Then Line1 = LBound(mCode)
48. If Line2 < Line1 Then Line2 = UBound(mCode)
49. Case Else
50. Exit Function
51. End Select
52. ReDim a(Line1 To Line2)
53. For nLine = Line1 To Line2
54. '取出每行代码
55. If TypeName(mCode) = \"CodeModule\" Then
56. strNewLine = mCode.Lines(nLine, 1)
57. Else
58. strNewLine = mCode(nLine)
59. End If
60. SrcDm = strNewLine
61. s = strNewLine
62. '把每行代码分离成代码和注释部分
63. strNewLine = SplitLine(s)
. strNewLine1 = Mid(s, Len(strNewLine) + 1) '注释
65. strNewLine = Trim(strNewLine) '代码
66. If strNewLine <> \"\" And strNewLine1 <> \"\" Then strNewLine1 = Space$(Sj) & strNewLine1
67. If sjCfg(2) = 1 Then strNewLine1 = \"\" '删除注释***
68. If nLine > Line1 Then
69. '删除双行空白行***
70. If sjCfg(3) = 1 And sjCfg(4) = 0 And LTrim(strNewLine) = \"\" And
strNewLine1 = \"\" And a(nLine - kh - 1) = \"\" Then
71. kh = kh + 1
72. End If
73. If sjCfg(4) = 1 And LTrim(strNewLine) = \"\" And strNewLine1 = \"\" Then
74. kh = kh + 1 '删除全部空白行***
75. GoTo 1
76. End If
77. End If
78. '进行缩放处理,把结果存放到数组中
79. If IsBlockEnd(strNewLine) Then nIndent = nIndent - 1 '关键字结束，下行减少一个缩进单位
80. If nIndent < 0 Then nIndent = 0
81. 'Put back new line.
82. If InStr(OldLine, \" _\") = 0 Then '正常行
83. a(nLine - kh) = IIf(strNewLine & strNewLine1 = \"\\"\Space$(nIndent * Sj) & strNewLine & strNewLine1)
84. If strNewLine = \"\" And strNewLine1 <> \"\" And sjCfg(1) = 0 Then a(nLine - kh) = SrcDm '注释缩进***
85. OldLine = IIf(strNewLine = \"\\"\Space$(nIndent * Sj) & strNewLine) '保存当前行(为判断折行做准备)
86. Else '折行
87. S1 = LTrim(OldLine)
88. i = InStr(S1, \" \")
. a(nLine - kh) = Space$(Len(OldLine) - Len(S1) + i) & strNewLine & strNewLine1
90. If InStr(strNewLine, \" _\") = 0 Then OldLine = \"\"
91. End If
92. i = IsBlockStart(strNewLine)
93. If i > 0 Then
94. nIndent = nIndent + 1 '关键字开始，下行增加一个缩进单位
95. If i = 2 Then '在程序中缩进***
96. a(nLine - kh) = LTrim(a(nLine - kh))
97. If a(nLine - kh) <> \"\" And sjCfg(5) = 1 And sjCfg(4) = 0 Then '过程函数名称前加一空行***
98. S1 = \"1\"
99. If nLine - kh > 1 Then S1 = Trim(a(nLine - kh - 1)): If Left(S1, 1) = \"'\" Then S1 = \"\"
100. If Len(S1) > 0 Then a(nLine - kh) = vbNewLine & a(nLine - kh)
101. End If
102. nIndent = 1
103. End If
104. End If
105. 1:
106. Next
107. '把数组一次性更新到模块中
108. i = Line2 - kh
109. ReDim Preserve a(Line1 To i)
110. S1 = Join(a, vbNewLine)
111. If a(Line1) <> \"\" And Line1 > 1 And sjCfg(5) = 1 And sjCfg(4) = 0 Then '过程函数名称前加一空行***
112. S1 = vbNewLine & S1
113. End If
114. If Right(S1, 4) = vbNewLine & vbNewLine Then S1 = Left(S1, Len(S1) - 2)
115. IndentCode1 = S1
116. End Function
117. Private Function IsBlockStart(strLine As String) As Integer
118. Dim nPos As Integer
119. Dim strTemp As String
120. Dim Head As Integer '函数头标识
121. strLine = LTrim(strLine)
122. nPos = InStr(1, strLine, \" \") - 1
123. If nPos < 0 Then nPos = Len(strLine)
124. strTemp = Left$(strLine, nPos)
125. Select Case strTemp
126. Case \"Sub\
127. Head = 2
128. Case \"With\\"#Else:\
129. Head = 1
130. Case \"If\
131. If (Len(strLine) = (InStr(1, strLine, \" Then\") + 4)) Or InStr(strLine, \" _\") > 0 Then Head = 1
132. Case \"Private\
133. 134. 135. 136. 137. 138. 139. nPos - 1)
140. 141. nPos = InStr(1, strLine, \" Static \")
If nPos Then
nPos = InStr(nPos + 7, strLine, \" \")
Else
nPos = InStr(Len(strTemp) + 1, strLine, \" \")
End If
Select Case Mid$(strLine, nPos + 1, InStr(nPos + 1, strLine, \" \") - Case \"Sub\
Head = 2
142. Case \"Enum\
143. Head = 1
144. End Select
145. End Select
146. IsBlockStart = Head
147. End Function
148. Private Function IsBlockEnd(strLine As String) As Boolean
149. Dim bOK As Boolean
150. Dim nPos As Integer
151. Dim strTemp As String
152. strLine = LTrim(strLine)
153. nPos = InStr(1, strLine, \" \") - 1
154. If nPos < 0 Then nPos = Len(strLine)
155. strTemp = Left$(strLine, nPos)
156. Select Case strTemp
157. Case \"Next\\"#Else:\
158. bOK = True
159. Case \"End\"
160. bOK = (Len(strLine) > 3)
161. End Select
162. IsBlockEnd = bOK
163. End Function
1. Public Function HandleError() As VbMsgBoxResult
165. HandleError = MsgBox(\"代码\" & Err.Source & \"错误：\" & vbCrLf & \"详细：\" & Err.Description _
166. & vbCrLf & \"错误号：\" & Err.Number, m_iErrMsg, App.Title)
167. End Function
168. Function HasCodeModule(VBComp) As Boolean
169. On Error GoTo ErrHandler
170. Select Case VBComp.Type
171. Case vbext_ct_ActiveXDesigner
172. HasCodeModule = True
173. Case vbext_ct_ClassModule
174. HasCodeModule = True
175. Case vbext_ct_DocObject
176. HasCodeModule = False
177. Case vbext_ct_MSForm
178. HasCodeModule = True
179. Case vbext_ct_PropPage
180. HasCodeModule = True
181. Case vbext_ct_RelatedDocument
182. HasCodeModule = False
183. Case vbext_ct_ResFile
184. HasCodeModule = False
185. Case vbext_ct_StdModule
186. HasCodeModule = True
187. Case vbext_ct_UserControl
188. HasCodeModule = True
1. Case vbext_ct_VBForm
190. HasCodeModule = True
191. Case vbext_ct_VBMDIForm
192. HasCodeModule = True
193. Case Else
194. HasCodeModule = False
195. End Select
196. ExitProc:
197. Exit Function
198. ErrHandler:
199. Err.Raise Err.Number, \"(HasCodeModule:\" & VBA.Erl & \")>\" & Err.Source, Err.Description
200. End Function
201. '获取命令行的主体部分
202. Function SplitLine(ByVal CmdLine As String) As String
203. Dim i As Integer, j As Integer, K As Integer, m As Integer, n As Integer, s As String, S1 As String
204. Dim Resu As String
205. If Trim(CmdLine) = \"\" Then SplitLine = CmdLine: Exit Function
206. 1:
207. i = InStr(CmdLine, \"'\")
208. If i Then
209. j = InStrRev(CmdLine, Chr(34), i, vbTextCompare)
210. If j Then
211. K = 0
212. Do While j > 0
213. If j > 1 Then
214. j = InStrRev(CmdLine, Chr(34), j - 1, vbTextCompare)
215. Else
216. j = 0
217. End If
218. K = K + 1
219. Loop
220. If K Mod 2 = 0 Then ''号前有偶数\"号
221. Resu = Resu & Left(CmdLine, i - 1)
222. Else ''号前有奇数\"号
223. i = InStr(i, CmdLine, Chr(34), vbTextCompare)
224. Resu = Resu & Left(CmdLine, i)
225. CmdLine = Mid(CmdLine, i + 1)
226. GoTo 1
227. End If
228. Else '有'号但没有\"号
229. Resu = Resu & Left(CmdLine, i - 1)
230. End If
231. Else '没有'号
232. Resu = Resu & CmdLine
233. End If
234. SplitLine = Resu
235. End Function
236. Sub ReadCfg() '读取缩进参数
237. Dim s As String, i As Integer, a() As String
238. ReDim sjCfg(5)
239. DefMenuName \"DefMenuName\"))
= Trim(GetSetting(\"DllAddin\\"config\
240. DefMenuCaption \"DefMenuCaption\"))
= Trim(GetSetting(\"DllAddin\\"config\
241. 'If DefMenuCaption = \"\" Then DefMenuCaption =
GetFileName(DefMenuName)
242. s = GetSetting(\"DllAddin\
243. a = Split(s, \
244. If UBound(a) < UBound(sjCfg) + 1 Then
245. s = \"4,1,1,0,1,0,1\" '默认
246. a = Split(s, \
247. End If
248. Sj = Val(a(0))
249. For i = 0 To UBound(sjCfg)
250. sjCfg(i) = Val(a(i + 1))
251. Next
252. End Sub
(三) 把下面代码保存为MyExcelAddin.vbp文件
1. Type=OleDll
2. Reference=*\\G{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}#2.0#0#C:\\Program Files\\Microsoft Office\\Office\\MSO9.DLL#Microsoft Office 8.0 Object
Library
3. Reference=*\\G{AC0714F2-3D04-11D1-AE7D-00A0C90F26F4}#1.0#0#C:\\Program Files\\Common Files\\designer\\MSADDNDR.TLB#Add-In Designer/Instance Control Library
4. Reference=*\\G{EF404E00-EDA6-101A-8DAF-00DD010F7EBB}#5.3#0#e:\\VB98\\VB6EXT.OLB#Microsoft Visual Basic 6.0 Extensibility
5. Reference=*\\G{00020813-0000-0000-C000-000000000046}#1.3#0#C:\\Program Files\\Microsoft Office\\Office\\EXCEL9.OLB#Microsoft Excel 9.0 Object Library
6. Designer=Connect.Dsr
7. Module=ModIndentCode; ModIndentCode.bas
8. Startup=\"(None)\"
9. HelpFile=\"\"
10. ExeName32=\"MyExcelAddin.dll\"
11. Command32=\"\"
12. Name=\"MyExcelAddin\"
13. HelpContextID=\"0\"
14. Description=\"Sample AddIn Project\"
15. CompatibleMode=\"0\"
16. MajorVer=1
17. MinorVer=0
18. RevisionVer=0
19. AutoIncrementVer=0
20. ServerSupportFiles=0
21. VersionCompanyName=\"888888\"
22. CompilationType=0
23. OptimizationType=0
24. FavorPentiumPro(tm)=0
25. CodeViewDebugInfo=0
26. NoAliasing=0
27. BoundsCheck=0
28. OverflowCheck=0
29. FlPointCheck=0
30. FDIVCheck=0
31. UnroundedFP=0
32. StartMode=1
33. Unattended=0
34. Retained=0
35. ThreadPerObject=0
36. MaxNumberOfThreads=1
37. DebugStartupOption=0
38. [MS Transaction Server]
39. AutoRefresh=1
40. (四) dll文件编译
打开MyExcelAddin.vbp文件,在Vb工作环境中编译成MyExcelAddin.dll文件.
(五) dll文件注册:
在开始菜单中选择\"运行\" ,输入 regsvr32 e:\\output\\MyExcelAddin.dll(请修改指定dll文件位置),然后回车即可.
如果你觉得上述过程太复杂,请直接到下面网址下载所需DLL文件:
http://www.kuaipan.com.cn/file/id_10655947005365401.htm
(六)操作指南:
MyExcelAddin.dll注册成功以后,你就可以打开Excel文件,在”工具”菜单下找到”代码缩进”工具条(注意:在Excel中,而不是在Visual Basic 编辑器环境中),点击它就可完成代码自动缩进的功能了.
因篇幅问题不能全部显示，请点此查看更多更全内容
Copyright © 2019- huatuo0.cn 版权所有 湘ICP备2023017654号-2
违法及侵权请联系：TEL:199 18 7713 E-MAIL:2724546146@qq.com
本站由北京市万商天勤律师事务所王兴未律师提供法律服务