原创并分享：我的得意代码

sxhus · 发表于 2013-8-21 21:31

good , 继续！

zhanglei1371 · 发表于 2013-8-21 21:34

10. 逐渐增大和缩小段落间距：应该也算是比较常用操作了，虽然网上有类似代码但都有一个缺陷：就是在缩小段落间距时，会在调整为固定段距时突然浓缩到一起，本方法随不完美，但基本解决了这一问题。快捷键：Alt+【和Alt+】
Sub 增大段落间距()
CustomizationContext = NormalTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyCloseSquareBrace, wdKeyAlt), KeyCategory:=wdKeyCategoryMacro, Command:="增大段落间距"
Application.ScreenUpdating = False
With Selection.ParagraphFormat
a = .LineSpacing
If a > 2000 Then a = Selection.Paragraphs(1).Range.ParagraphFormat.LineSpacing
      .LineSpacing = a + 1
End With
Application.ScreenUpdating = True
End Sub
Sub 缩小段落间距()
CustomizationContext = NormalTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyOpenSquareBrace, wdKeyAlt), KeyCategory:=wdKeyCategoryMacro, Command:="缩小段落间距"
On Error Resume Next
Application.ScreenUpdating = False
With Selection.ParagraphFormat
If .LineSpacingRule <> wdLineSpaceExactly Then .LineSpacing = Selection.Range.Paragraphs(1).Range.Sentences(1).Characters(1).Font.Size + 15
      .LineSpacingRule = wdLineSpaceExactly
      .LineSpacing = .LineSpacing - 0.3
End With
Application.ScreenUpdating = True
End Sub

zhanglei1371 · 发表于 2013-8-21 21:40

本帖最后由 zhanglei1371 于 2013-8-21 22:07 编辑

11.  批量文件替换：本方法用递归的形式来完成文件目录下的word文档替换。大家应该知道，word2003中可用filesearch方法对文件下的子目录中的文档进行操作，但是到了07版之后就没用了。当时请教了不少人也没得到回复。费了不少劲从网上找到Excel的操作，取其本源代码转换成了word的代码，本方法适用于各个版本。
而且在替换中可采用两种方式：
一、通配符替换，熟悉替换的朋友应该都知道；
二、正则表达式替换：此为本人原创的方法，整合到此过程中，通过对话框形式可选择正则方法，用于弥补通配符的不足，但是需要指出的是，正则替换会破坏掉原文的格式。对于需要保留格式的文章勿选择。
Sub 批量文件夹替换()
Dim FID As String
Dim REP As String
Dim TF As Boolean
On Error Resume Next
If MsgBox("要使用正则替换吗？", vbYesNo + vbExclamation, "正则判断") = vbYes Then
      TF = True
      FID = InputBox("请输入要查找的目标：【正则模式】", "正则查找...", FID)
      If FID = "" Then Exit Sub
      REP = InputBox("请输入要替换为的表达式：【正则模式】", "正则替换替换...", REP)
Else
      FID = InputBox("请输入要查找的目标：", "查找...", FID)
      If FID = "" Then Exit Sub
      REP = InputBox("请输入要替换为的表达式", "替换...", REP)
End If
' If REP = "" Then Exit Sub
With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "请定位要处理的文件夹..."
      If .Show <> -1 Then Exit Sub
      bc = .SelectedItems(1)
End With
bc0 = Left(bc, 3)
Debug.Print bc, bc0
ChDrive bc0
ChDir (bc)
F = Dir("*.doc")
Do While F <> ""
      With Documents.Open(bc & Application.PathSeparator & F, Visible:=True)
         Application.ScreenUpdating = False
         '*---------------------测试代码------------------------------------*
                  If TF = True Then
                     Call 正则替换(FID, REP)
                  Else
                     Call 查找替换子过程(FID, REP)
                  End If
         'ActiveDocument.content.Find.Execute FID, , , 2, , , , , , REP, 2
         '*-------------------------------------------------------------------*
         Application.ScreenUpdating = False
         .Close True
      End With
      F = Dir
Loop
查找子目 bc, FID, REP, TF
End Sub
Function 查找替换子过程(FID, REP)
ActiveDocument.Content.Find.Execute FID, , , 2, , , , , , REP, 2
End Function
Function 查找子目(ByVal TD As String, FID As String, REP As String, TF As Boolean)
Dim fs As New FileSystemObject
If fs.FolderExists(TD) Then
      If Len(fs.GetFolder(TD)) = 0 Then
         Debug.Print "文件夹" & TD & " 是空的！"
      Else
         Dim Zi
         For Each Zi In fs.GetFolder(TD).SubFolders
            For Each F In Zi.Files
                  '*--------------------------测试代码------------------------------------*
                  If F.Type = "Microsoft Word 文档" Then
                     With Documents.Open(CStr(F), Visible:=True)
                        Application.ScreenUpdating = False
                        '*-----------------------------------------------------------------------------------------------*
                     If TF = True Then
                     Call 正则替换(FID, REP)
                  Else
                     Call 查找替换子过程(FID, REP)
                  End If
                        '*-----------------------------------------------------------------------------------------------*
                        Application.ScreenUpdating = True
                        '*-------------------------------------------------------------------*
                        .Close True
                     End With
                  End If
            Next
            查找子目 Zi, FID, REP, TF '！递归！
         Next
      End If
End If
End Function
Function 正则替换(Pattern As String, tar As String)
Dim a As Object
Dim S As Range
Set S = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
Set a = CreateObject("VBscript.regexp")
With a
.Global = True
.MultiLine = True
.Pattern = Pattern
S = .Replace(S, tar)
End With
   S.Select
  Set S = Nothing
Set a = Nothing
End Function

zhanglei1371 · 发表于 2013-8-21 21:43

12. 批量导入模块：用于VBE界面下批量导入过程文件，因为正常情况下一次只能选择一个。
Sub 批量导入模块()
Dim NV As VBProject
On Error Resume Next
Set NV = NormalTemplate.VBProject
Debug.Print NV.Name
With Application.FileDialog(msoFileDialogFilePicker)
      .Title = "请选择模块文件..."
      .Filters.Add "模块文件", "*.cls;*.bas;*.frm"
      If .Show <> -1 Then Exit Sub
      For Each F In .SelectedItems
         NV.VBComponents.Import F
      Next
End With
End Sub

zhanglei1371 · 发表于 2013-8-21 21:51

13. 最后一个，也是最长的一个了。用于分组列出当前模块的vba过程。初学VBA的朋友可能会经常写自己需要的代码，为了方便会将其放到word工具栏，但每次都要点工具-自定义-宏-再寻找-拖动，就显得太麻烦了。本代码参照了论坛中前辈们的一部分，自己加入了随机系统和分组形式。令其更加使用。
代码的作用：将当期模块中所有的过程都枚举出来，自动在word前台工具栏生成菜单。相信使用过一些word工具箱的朋友们不会陌生，也有类似功能，但是据我观察那些工具箱基本都是将所有的过程一下全都列出来，如果就几十个还好，加入有几百个VBA过程的话，呵呵，word不累惨也差不多。
Sub 分组列出当前模块VBA()
Dim bDoc As Document
Dim objProject As VBIDE.VBProject
Dim objComponent As VBIDE.VBComponent
Dim objCode As VBIDE.CodeModule
Dim iLine As Integer, C As Integer, D As Integer
Dim sProcName As String
Dim pk As vbext_ProcKind
Application.ScreenUpdating = False
P = 1: M = 1: sj = 随机数字
Dim j As Integer
Dim a As CommandBar
For Each a In Application.CommandBars
      Debug.Print a.Name
      If a.Name = "新增" Then
         Application.CommandBars("新增").Delete
         Exit For
      End If
Next
Set G = Application.CommandBars.Add("新增")
G.Visible = True
G.Enabled = True
G.Position = msoBarTop
Set objCode = VBE.ActiveCodePane.CodeModule
iLine = 1
'*-----------------------------------------------------------------------------------*
SR = InputBox("请输入你想要生成下拉菜单中的项目个数：", "自动列出vba项目", 1)
If SR = 1 Then
      Do While iLine < objCode.CountOfLines
         sProcName = objCode.ProcOfLine(iLine, pk)
         If sProcName <> "" Then
            With Application.CommandBars("新增").Controls.Add(msoControlButton, 1)
                  .Caption = sProcName & "-" & M '命名
                  .TooltipText = sProcName '鼠标留置时的提示名，默认和上面的一样
                  Debug.Print sProcName
                  .FaceId = Val(Split(sj, ":")(M))
                  .OnAction = sProcName 'sub过程名
                  .Style = msoButtonIconAndCaption
            End With
            M = M + 1
            iLine = iLine + objCode.ProcCountLines(sProcName, pk)
         Else
            iLine = iLine + 1
         End If
      Loop
      Exit Sub
End If
For j = 1 To Application.CommandBars("新增").Controls.Count
      If sn = Application.CommandBars("新增").Controls(j).OnAction Then Exit Sub
Next
Set OC = Application.CommandBars("新增").Controls.Add(Type:=msoControlPopup, ID:=1)
With OC
      .Caption = "AZA"
      .BeginGroup = True
End With
Do While iLine < objCode.CountOfLines
      sProcName = objCode.ProcOfLine(iLine, pk)
      If sProcName <> "" Then

         If j > SR Then
            j = 1
            Set OC = Application.CommandBars("新增").Controls.Add(Type:=msoControlPopup, ID:=1)
            P = P + 1
            With OC
                  .Caption = "AZA" & P
                  .BeginGroup = True
            End With
         End If
         With OC.Controls.Add(msoControlButton, 1)
            .Caption = sProcName & "-" & M '命名
            .TooltipText = sProcName '鼠标留置时的提示名，默认和上面的一样
            Debug.Print sProcName
            .FaceId = Val(Split(sj, ":")(M))
            .OnAction = sProcName 'sub过程名
            .Style = msoButtonIconAndCaption
         End With
         j = j + 1
         M = M + 1
         Debug.Print Val(Split(sj, ":")(M))
         iLine = iLine + objCode.ProcCountLines(sProcName, pk)
      Else
         iLine = iLine + 1
      End If
Loop
Application.ScreenUpdating = True
End Sub
Function 随机数字()
Randomize Timer
      S = 255
Dim C(255) As Byte
For i = 1 To S '产生100个随机数
      C(i) = i
Next
k = S
Do While L < S
      R = Int(Rnd() * k) + 1 '随机数的范围
      aa = C(R)
      C(R) = C(k)
      C(k) = aa
      k = k - 1
      L = L + 1
      ss = ss & ":" & aa
Loop
随机数字 = ss
End Function
'*--------------------***-----------------------------------------*--------------------------------------***

zhanglei1371 · 发表于 2013-8-21 21:58

还有个增加图片另存菜单的，发布在这里了，也算是半原创吧，应该也是常用的一个程序：
http://club.excelhome.net/thread-1047889-1-1.html
基本就这些了。代码水平不高，呵呵，希望能为VBA入门的朋友带来一些帮助，因为我在入门时，为了解决头几个代码，花了很长很长时间不得结果。直至数月之后回过头来才逐渐找到答案，也希望和大家共同进步！