[原创]VBE中文代码复制器

守柔

守柔

以下代码供参考:

'****　I Love You_Word!　Create　2004-11-23　　****

'^[ThisDocument-ThisDocument]^'

Dim MyVbeProject As MyClass

Sub AutoExec()

On Error Resume Next

'加载时自动加载"VBIDE"库文件和运行AddMybar的过程

Me.VBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"

'引用VBIDE库文件,引用名为"Microsoft Visual Basic for Applications Extensibility 5.3",版本不同可能略有差异

AddMyBar

End Sub

'----------------------

Sub AutoExit()

On Error Resume Next

'卸载时自动去除"VBIDE"引用

With Me.VBProject

Set ref = .References("VBIDE")

If Not ref Is Nothing Then

.References.Remove ref

End If

End With

DelMyBar

End Sub

'----------------------

Sub AddMyBar()

Dim MyBar As CommandBarControl

On Error Resume Next

DelMyBar '先删除后增加

Set MyBar = Application.VBE.CommandBars("Code Window").Controls.Add

With MyBar

.Caption = "GetCopy"

.FaceId = 19

Set MyVbeProject = New MyClass '将MyVbeProject定义为新MyClass类

Set MyVbeProject.MyProject = Application.VBE.Events.CommandBarEvents(MyBar)

'此句代码意为该MyvbeProject类中的MyProject过程是指向(响应)命令MyBar的单击事件

'MyBar是该事件的源对象,此事件相当于CommandControl的OnAction属性 End With

End With

End Sub

'----------------------

Sub DelMyBar()

On Error Resume Next

'删除VBE右键中的一个"GetCopy"的命令按钮,使其还原

Application.VBE.CommandBars("Code Window").Controls("GetCopy").Delete

End Sub

'----------------------

'****　I Love You_Word!　Create　2004-11-23　　****

'^[类模块-MyClass]^'

Public WithEvents MyProject As VBIDE.CommandBarEvents

Private Sub MyProject_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)

Dim i As Integer, Avs As Object, strSub As String, ComType As String

Set Avs = Application.VBE.SelectedVBComponent

i = Avs.CodeModule.CountOfLines

Select Case Avs.Type

Case 1

ComType = "标准模块"

Case 2

ComType = "类模块"

Case 3

ComType = "用户窗体"

Case 100

ComType = "ThisDocument"

Case Else

ComType = "未知模块"

End Select

With Selection

.Collapse Direction:=wdCollapseEnd

.InsertAfter "'****　" & Application.UserName & "　Create　" & Date & "　" & _

"　****" & vbCrLf

.InsertAfter "'^[" & ComType & "-" & Avs.Name & "]^'" & vbCrLf

.Font.Bold = True

For n = 1 To i

strSub = Avs.CodeModule.Lines(n, 1)

If strSub Like "End Sub*" = True Or strSub Like "End Type*" = True Or _

strSub Like "End Function*" = True Then strSub = strSub & vbCrLf & "'----------------------"

.InsertAfter strSub & vbCrLf

Next

.Font.Name = "Tahoma"

.Font.Size = 12

.Font.Color = wdColorBlue

.Paragraphs(1).Range.Font.Color = wdColorRed

.Paragraphs(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter

.Cut

End With

End Sub

'----------------------

守柔

经Taller版主指点，重新改写了部分代码，自动判断是否有选中内容，如果有选中内容，则自动转换复制选中部分（整行），如果未予选中则进行所有当前模块中的所有代码进行转换复制。

WS6d5On5.rar (13.87 KB, 下载次数: 72)

2004-11-25 05:14 上传

点击文件名下载附件
[原创]VBE中文代码复制器

以下代码供参考：

'****　I Love You_Word!　Create　2004-11-25　　****

'^[ThisDocument-ThisDocument]^'

Dim MyVbeProject As MyClass

Sub AutoExec()

On Error Resume Next

'加载时自动加载"VBIDE"库文件和运行AddMybar的过程

Me.VBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"

'引用VBIDE库文件,引用名为"Microsoft Visual Basic for Applications Extensibility 5.3",版本不同可能略有差异

AddMyBar

End Sub

'----------------------

Sub AutoExit()

On Error Resume Next

'卸载时自动去除"VBIDE"引用

With Me.VBProject

Set ref = .References("VBIDE")

If Not ref Is Nothing Then

.References.Remove ref

End If

End With

DelMyBar

End Sub

'----------------------

Sub AddMyBar()

Dim MyBar As CommandBarControl

On Error Resume Next

DelMyBar '先删除后增加

Set MyBar = Application.VBE.CommandBars("Code Window").Controls.Add

With MyBar

.Caption = "GetCopy"

.FaceId = 19

Set MyVbeProject = New MyClass '将MyVbeProject定义为新MyClass类

Set MyVbeProject.MyProject = Application.VBE.Events.CommandBarEvents(MyBar)

'此句代码意为该MyvbeProject类中的MyProject过程是指向(响应)命令MyBar的单击事件

'MyBar是该事件的源对象,此事件相当于CommandControl的OnAction属性 End With

End With

End Sub

'----------------------

Sub DelMyBar()

On Error Resume Next

'删除VBE右键中的一个"GetCopy"的命令按钮,使其还原

Application.VBE.CommandBars("Code Window").Controls("GetCopy").Delete

End Sub

'----------------------

'****　I Love You_Word!　Create　2004-11-25　　****

'^[类模块-MyClass]^'

Public WithEvents MyProject As VBIDE.CommandBarEvents

Private Sub MyProject_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)

Dim i As Long, Avs As Object, strSub As String, ComType As String

Dim RowStart As Long, ColStart As Long, RowEnd As Long, ColEnd As Long

With Application

.ScreenUpdating = False

Set Avs = .VBE.SelectedVBComponent

.VBE.ActiveCodePane.GetSelection RowStart, ColStart, RowEnd, ColEnd

If RowStart = RowEnd And ColStart = ColEnd Then

m = 1: n = Avs.CodeModule.CountOfLines

ElseIf ColEnd = 1 Then

m = RowStart: n = RowEnd - 1

Else

m = RowStart: n = RowEnd

End If

Select Case Avs.Type

Case 1

ComType = "标准模块"

Case 2

ComType = "类模块"

Case 3

ComType = "用户窗体"

Case 100

ComType = "ThisDocument"

Case Else

ComType = "未知模块"

End Select

With Selection

.Collapse Direction:=wdCollapseEnd

.InsertAfter "'****　" & Application.UserName & "　Create　" & Date & "　" & _

"　****" & vbCrLf

.InsertAfter "'^[" & ComType & "-" & Avs.Name & "]^'" & vbCrLf

.Font.Bold = True

For i = m To n

strSub = Avs.CodeModule.Lines(i, 1)

If strSub Like "End Sub*" = True Or strSub Like "End Type*" = True Or _

strSub Like "End Function*" = True Then strSub = strSub & vbCrLf & "'----------------------"

.InsertAfter strSub & vbCrLf

Next

.Font.Name = "Tahoma"

.Font.Size = 11

.Font.Color = wdColorBlue

.Paragraphs(1).Range.Font.Color = wdColorRed

.Paragraphs(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter

.Cut

End With

.ScreenUpdating = True

End With

End Sub

'----------------------

守柔

mqIuLXJO.rar (17.15 KB, 下载次数: 128)

2004-11-28 06:07 上传

点击文件名下载附件

根据办公之星的提醒，已将复制代码中的回车符改为手动换行符,并添加了一个代码头和小说明。 效果如下：

'* +++++++++++++++++++++++++++++++++++++++

'* Created By 守柔@ExcelHome 2004-11-28 6:09:58

'仅测试于System: Windows NT Word: 10.0 Language: 2052

'^The Code CopyIn [ThisDocument-ThisDocument]^'

'* --------------------------------------------------------------------------

Sub Test() Dim i As Integer, Avs As Object, strSub As String Set Avs = Application.VBE.SelectedVBComponent i = Avs.CodeModule.CountOfLines With Selection .Collapse Direction:=wdCollapseEnd For n = 1 To i strSub = Avs.CodeModule.Lines(n, 1) .InsertAfter strSub & Chr(13) Next .Copy .Delete End With End Sub '----------------------

[此贴子已经被作者于2004-11-28 6:11:02编辑过]

kfz

看后糊涂,太难明白.

henterwu

那就一起慢慢消化吧，谢谢守柔的作品，收藏！！！

grewrabbit

好象word2003对中文支持的很好

三戒

老大的工程加了密