word常用宏
1.删除全文空白行
由于空行的前面可能会有一些空白符号，经我观察，空白字符有6种：全角空格、半角空格、不间断空格、制表符、换行符、回车符，所以如果空白行中有这些东西的话，常规方法难以一下除去，故本过程将这些全部考虑在内。为了提高速度，只用一次替换完成。
Sub 删除全文空白行()
Application.ScreenUpdating = False
t = Timer
Dim S As Range
Set S = ActiveDocument.Content '
S.Find.Execute "^13[ ^t" & ChrW(160) & "^11^13]{1,}", , , 2, , , , , , "^p", 2
Set S = Nothing
Application.ScreenUpdating = True
MsgBox Timer - t ‘消耗时间
End Sub
2.删除段落首位空白
有时我们从网上下载网文，很多时候段落前后会有空白，其实最快的方法就是按Ctrl+E和Ctrl+J完成即可。
用代码表示的话可以用Sendkeys来模拟按键，版块内有这样的帖子，然而个人感觉sendkeys方法不太可靠，因为我遇到过用了后有时会出现内容消失的情况。
故想到直接去执行工具栏图标的方式完成：
Sub 去除段落首尾空格()
CommandBars.FindControl(ID:=122).Execute
CommandBars.FindControl(ID:=123).Execute
End Sub
这样便相当于按了一次居中和两端对齐的按钮。
3.我的段落缩进
这应该是我非常满意的作品了。花了我不少时间去反复改进，也是我目前应用最频繁的代码了。作用就是将选定范围的段落首位空格去掉，同时将选定范围的空行去除，若有标题则调整居中，正文格式则首行缩进2.
Sub 我的缩进()
On Error Resume Next
Dim t As Single, pa As Paragraph, sp As Integer
Application.ScreenUpdating = False
t = Timer
Dim S As Range
sp = Selection.End
Set S = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range) '经典选择语句！！！
If S = ActiveDocument.Content Then
AB = MsgBox("要进行全文缩进处理吗？", vbYesNoCancel + vbQuestion, "全文处理判断")
If AB <> vbYes Then Exit Sub
End If
S.Select
For Each pa In Selection.Paragraphs
With pa ’从此处向下为对三级标题的设置，大家使用时可按自己喜好DIY。
If .Style = ("标题 1") Then
.Range.Font.Size = 30
.Range.Font.Bold = True
https://www.360docs.net/doc/cb16870966.html, = "华文行楷"
.Range.Font.Color = wdColorRed
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
ElseIf .Style = ("标题 2") Then
https://www.360docs.net/doc/cb16870966.html,FarEast = "华文隶书"
https://www.360docs.net/doc/cb16870966.html,Ascii = "Arial"
.Range.Font.Size = 21
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Range.Font.Color = wdColorRed
ElseIf .Style = ("标题 3") Then
.
Range.Font.Size = 16
.Range.Font.Bold = True
.Range.Font.Color = wdColorBlue
' https://www.360docs.net/doc/cb16870966.html, = "华文新魏"
https://www.360docs.net/doc/cb16870966.html, = "楷体_GB2312"
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
ElseIf .Style = "正文" Then
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = 2
Else
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = 2
End If
End With
sp = 0
Do While pa.Range.Characters(1) Like "[" & Chr$(9) & ChrW(160) & ChrW("&H" & "0020") & ChrW("&H" & "E5E5") & Chr$(32) & " ""]"
pa.Range.Characters(1) = ""
sp = sp + 1
If sp > 100 Then Exit Do '因为有的空格删之不去，加上这两句以防死循环！
Loop
pa.Range.Select
If Len(pa.Range) = 1 Then GoTo aaa:
sp = 0
Do While pa.Range.Characters(pa.Range.Characters.Count - 1) Like "[" & Chr$(9) & ChrW(160) & t16 & ChrW("&H" & "0020") & ChrW("&H" & "E5E5") & Chr$(32) & " ""]"
pa.Range.Characters(pa.Range.Characters.Count - 1) = ""
sp = sp + 1
If sp > 100 Then Exit Do
Loop
aaa:
If Len(pa.Range) = 1 Then pa.Range.Delete
S.Select
Next
Application.ScreenUpdating = True
If Timer - t > 5 Then MsgBox "已完成！共消耗时间为：" & Timer - t
End Sub
4.自动编号替换为手动编号，word自动编号可以为熟练掌握者在排版时提供很大的便利，而这种自作聪明的自动生成也会让不熟练者非常抓狂。因为自动的变化不容易控制。那么下面这段代码就将其自动转为手动编号，其实核心代码就是第四句。为了令其更规范，将其编号格式进一步替换成为半角点+空格的形式。
Sub 自动编号替换为手动编号()
Dim S As Range
If Selection.Type = wdSelectionIP Then Selection.Expand wdParagraph
Set S = Selection.Range
Selection.Range.ListFormat.ConvertNumbersToText
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([0-9]{1,})([.．、^9^32" & ChrW(160) & ChrW(12288) & "]{1,})"
.Wrap = 0
.Replacement.Text = "\1. " ‘此处可改为顿号或其他
.MatchWildcards = 1
.Execute Replace:=wdReplaceAll
End With
End Sub
5. 批量设定选定区域图片宽度，虽然网上也有类似的代码，但多是对全文进行的操作，而且只对一种有效。本方法适用于嵌入式和浮动式图片，而且仅对选定区域的有效不影响全文其他部分。
Sub 批量设定选定区域图片宽度()
On Error Resume Next
M = InputBox("请输入要调整图片的宽度：", "厘米单位", 14) * 28.35
If Selection.Type = wdSelectionInlineShape Then
For n = 1 To Selection
.InlineShapes.Count
pw = Selection.InlineShapes(n).Width
ph = Selection.InlineShapes(n).Height
Selection.InlineShapes(n).Width = M
Selection.InlineShapes(n).Height = ph * M / pw
Next
ElseIf Selection.Type = wdSelectionShape Then
Selection.ShapeRange.Width = M
ElseIf Selection.Type = wdSelectionNormal Then
Selection.Range.ShapeRange.Width = M
For n = 1 To Selection.Range.InlineShapes.Count
pw = Selection.Range.InlineShapes(n).Width
ph = Selection.Range.InlineShapes(n).Height
Selection.Range.InlineShapes(n).Width = M
Selection.Range.InlineShapes(n).Height = ph * M / pw '11111
Next
End If
End Sub
6. 每行插入表格n个图：这段代码也是我非常满意的代码之一。作用就是将选中的多个图像以表格+文件名的形式插入到文档中，而且自动根据每行插入的图像的个数来调整图像的比例大小。n为每行你要显示的图像数量。
Sub 每行插入表格n个图()
On Error Resume Next
Application.ScreenUpdating = False
Dim D As FileDialog, a, P As InlineShape, t As Table
If https://www.360docs.net/doc/cb16870966.html,rmation(wdWithInTable) = True Then MsgBox "请将光标置于表格之外！": Exit Sub
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选择..."
If .Show = -1 Then
n = InputBox("请输入表格的列数：", "列数", 3)
M = .SelectedItems.Count
Debug.Print "共有" & M & "个图片"; M
h = IIf(M / n = Int(M / n), 2 * M / n, 2 * (Int(M / n) + 1))
Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
t.Borders.Enable = True
t.Borders.OutsideLineStyle = wdLineStyleDouble
For Each a In .SelectedItems
B = Split(a, "\")(UBound(Split(a, "\")))
C = Split(B, ".")(0)
Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
With P
w = .Width
.Width = Int(410 / n)
.Height = .Width * .Height / w
End With
i = i + 1
Selection.MoveLeft wdCharacter, 1
Selection.MoveDown wdLine, 1
Selection.TypeText C
Selection.Cells(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '决定了首行居中
Selection.HomeKey
Selection.MoveDown wdLine, -1
Selection.MoveRight wdCharacter, 2
Debug.Print i, n
If i = Val(n) Then
Selection.MoveRight wdCharacter, 1
Selection.Cells(1).Select
Selection.EndKey
Selection.MoveDown wdLine, 1
i = 0
End If
Next
End If
End With
Application.ScreenUpdating = True
End Sub
7. 表格行列转置代码，本代码能够实现表格行变成列，列变成行，也就是翻转90度吧，论坛有类似的代码，但本代码的特点在于加入原来表格有格式的话，比如颜色，再转置后能保留格式不丢失。
Sub 表格行列转置()
On Error Resume Next
Dim a As Table, B As Table
Set a = Selection.Tables(1)
Debug.Print a.Cell(1, 2).Range.Text
i = a.Rows.Count
j = a.Columns.Count
Selection.EndKey wdStory
Selection.TypeParagraph
Set B = Selection.Tables.Add(Selection.Range, j, i)
B.Borders.Enable = 1
For S = 1 To i
For P = 1 To j
Debug.Print S, P
Debug.Print a.Cell(S, P).Range.Text
Text = a.Cell(S, P).Range
B.Cell(P, S).Range = Mid(Text, 1, Len(Text) - 2) '不用mid会自动生成回车
B.Cell(P, S).Range.Font.Color = a.Cell(S, P).Range.Font.Color
B.Cell(P, S).Shading.BackgroundPatternColor = a.Cell(S, P).Shading.BackgroundPatternColor
Next
Next
a.Delete
End Sub
8. 四重查找替换，本代码主要是让喜欢查找替换的朋友做一个参考，并不是像上面代码一样直接拿来使用，作用就是逐渐缩小范围来查找，直至缩小四次。有兴趣的朋友可在word文档键入=rand(15,3)回车测试下。
Sub 四重查找()
Selection.HomeKey wdStory
'With Selection.Find
With ActiveDocument.Content.Find
.Text = "那只[!^13]@懒狗[!^13]@^13"
.MatchWildcards = 1
Do While .Execute
.Parent.Select
.Parent.Font.Color = wdColorBrightGreen
Dim S As Range, P As Range, R As Range
Set ss = Selection.Range
Set S = Selection.Range.Duplicate
With S.Find
.Text = "敏捷*那只"
.MatchWildcards = 1
Do While .Execute
If Not .Parent.InRange(ss) Then
Exit Do
Else
.Parent.Font.Color = wdColorBlue
End If
Debug.Print .Parent
Set P = .Parent.Duplicate
With P.Find
.Text = "棕毛*跃过"
.MatchWildcards = 1
Do While .Execute
If Not .Parent.InRange(ss) Then
Exit Do
Else
.Parent.Font.Color = wdColorPink
End If
Debug.Print .Parent
Set R = .Parent.Duplicate
With R.Find
.Text = "狐狸"
.MatchWildcards = 1
.Replacement.Font.Color = vbRed
.Execute , , , , , , , , , , 2
.Text = "狐"
.Replacement.Font.Size = 24
.Replacement.Font.Bold = 1
.Replacement.Font.Color = wdColorBlack
.Execute , , , , , , , , , , 2
End With
Loop
End With
Loop
End With
Loop
End With
End Sub
9. 干掉不正常的大纲级别：经常排版懂得自动生成目录的朋友可能会遇到这样的情况，就是在自动生成的目录总会有大段大段的文本段落混在当中，而定位到这些段落时又发现和周围的正文没有区别，其实是这些文本的大纲级别为123级造成的，下面的代码用于解决这样的情况。
Sub 干掉不正常的大纲级别()
On Error Resume Next
Application.ScreenUpdating = False
t = Timer
Dim S As Paragraph
For Each S In ActiveDocument.Paragraphs
If S.OutlineLevel = wdOutlineLevel1 And S.Range.ParagraphFormat.Style <> "标题 1" Then
S.OutlineLevel = wdOutlineLevelBodyText
ElseIf S.OutlineLevel = wdOutlineLevel2 And S.Range.ParagraphFormat.Style <> "标题 2" Then
S.OutlineLevel = wdOutlineLevelBodyText
ElseIf S.OutlineLevel = wdOutlineLevel3 And S.Range.ParagraphFormat.Style <> "标题 3" Then
S.OutlineLevel = wdOutlineLevelBodyText
End If
Next
Application.ScreenUpdating = True
If ActiveDocument.Path <> "" Then ActiveDocument.Save
If Timer - t > 5 Then MsgBox "已完成！共消耗时间为：" & Timer - t
End Sub
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
Applic
ation.ScreenUpdating = True
End Sub
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
12. 批量导入模块：用于VBE界面下批量导入过程文件，因为正常情况下一次只能选择一个。
Sub 批量导入模块()
Dim NV As VBProject
On Error Resume Next
Set NV = NormalTemplate.VBProject
Debug.Print https://www.360docs.net/doc/cb16870966.html,
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
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 https://www.360docs.net/doc/cb16870966.html,mandBars
Debug.Print https://www.360docs.net/doc/cb16870966.html,
If https://www.360docs.net/doc/cb16870966.html, = "新增" Then
https://www.360docs.net/doc/cb16870966.html,mandBars("新增").Delete
Exit For
End If
Next
Set G = https://www.360docs.net/doc/cb16870966.html,mandBars.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 https://www.360docs.net/doc/cb16870966.html,mandBars("新增").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 https://www.360docs.net/doc/cb16870966.html,mandBars("新增").Controls.Count
If sn = https://www.360docs.net/doc/cb16870966.html,mandBars("新增").Controls(j).OnAction Then Exit Sub
Next
Set OC = https://www.360docs.net/doc/cb16870966.html,mandBars("新增").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 = https://www.360docs.net/doc/cb16870966.html,mandBars("新增").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
'*--------------------***-----------------------------------------*--------------------------------------***
近日看了怎么用ＶＢＡ把ＷＯＲＤ里的所有图片另存成文件？？的帖子，心有所悟，于是便花了些时间来做了这个很久前就像实现的目标，近日终于做成功了，其实主要的代码还是来自于网络，我的工作就是将他们整合在了一起，并添加入右键，实现一键保存图片的目的。
本代码可达到：
1.保存浮动式图形；
2.保存嵌入式图形；
3.保存文本框
4.保存艺术字
如下：
'Thisdocument中：
Private Sub Document_Open()
Dim cbn
For Each cbn In Array("Inline Picture", "Floating Picture", "Shapes", "WordArt Context Menu")
CommandBars(cbn).Reset
With CommandBars(cbn).Controls.Add(msoControlButton, Before:=4)
.Caption = "图片另存为"
.FaceId = 307
.OnAction = "图片另存为"
.Style = msoButtonIconAndCaption
End With
Next
End Sub
'标准模块中：
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declar
e Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public iClipBoardFormatNumber As Long
Enum picFormat
pic_GIFformat = 1
pic_jpgformat = 2
pic_pngformat = 3
End Enum
Sub savePic(shp As Shape, picFormat As picFormat, sFileName As String)
'这个过程把工作表中的shape对象另存为图像文件，需要指定要导出的shape对象 - shp
'导出文件格式 - picFormat（有1,2,3三种选择，分别代表gif，jpg和png格式），目标文件名 - sFileName
Set fs = Nothing
Dim nClipsize As Long
Dim hMem As Long
Dim lpData As Long
Dim sdata() As Byte
shp.Select
Selection.Copy
OpenClipboard 0&
If iClipBoardFormatNumber = 0 Then
For i = 40000 To 60000
If IsClipboardFormatAvailable(i) And IsClipboardFormatAvailable(i + 1) And IsClipboardFormatAvailable(i + 2) And IsClipboardFormatAvailable(i + 3) Then
iClipBoardFormatNumber = i
Exit For
End If
Next
End If
On Error GoTo myError:
hMem = GetClipboardData(iClipBoardFormatNumber + picFormat)
If CBool(hMem) Then
nClipsize = GlobalSize(hMem)
lpData = GlobalLock(hMem)
If lpData <> 0 Then
ReDim sdata(0 To nClipsize) As Byte
CopyMemory sdata(0), ByVal lpData, nClipsize
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.fileExists(sFileName) Then
Kill sFileName
End If
Open sFileName For Binary As #1
Put #1, , sdata
Close #1
End If
GlobalUnlock hMem
Else
GoTo myError
End If
EmptyClipboard
CloseClipboard
Exit Sub
myError:
GlobalUnlock hMem
EmptyClipboard
CloseClipboard
MsgBox "export failed!"
End Sub
Function 文件另存()
Dim i As Integer
Dim kuang As OPENFILENAME
Dim filename As String
kuang.lStructSize = Len(kuang)
kuang.hwndOwner = 0& 'ThisDocument.hwnd
kuang.hInstance = 0& 'App.hInstance
kuang.lpstrFile = Space(254)
kuang.nMaxFile = 255
kuang.lpstrFileTitle = Space(254)
kuang.nMaxFileTitle = 255
'kuang.lpstrInitialDir = App.Path
kuang.flags = 6148
'过虑对话框文件类型
kuang.lpstrFilter = "图像1(*.jpg)" & Chr$(0) & "*.jpg" & Chr$(0) & "图像2(*.bmp)" & Chr$(0) & "*.bmp" & Chr$(0) & "图像3(*.gif)
" & Chr$(0) & "*.gif" & Chr$(0) & "所有文件(*.*)" & Chr$(0) & "*.*" & Chr$(0)
'对话框标题栏文字
kuang.lpstrTitle = "保存文件的路径及文件名..."
kuang.lpstrDefExt = kuang.lpstrFilter
kuang.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_OVERWRITEPROMPT
i = GetSaveFileName(kuang) '显示保存文件对话框
If i >= 1 Then '取得对话中用户选择输入的文件名及路径
filename = kuang.lpstrFile
filename = Left(filename, InStr(filename, Chr(0)) - 1)
End If
If Len(filename) = 0 Then Exit Function
'保存代码
文件另存 = filename
End Function
Sub 图片另存为()
Dim fn As String, pic As Long
CloseClipboard
fn = 文件另存
If fn = "" Then Exit Sub
If Split(fn, ".")(UBound(Split(fn, "."))) = "gif" Then
pic = pic_jpgformat
ElseIf Split(fn, ".")(UBound(Split(fn, "."))) = "jpg" Then
pic = pic_jpgformat
ElseIf Split(fn, ".")(UBound(Split(fn, "."))) = "png" Then
pic = pic_pngformat
End If
If Selection.Type = wdSelectionInlineShape Then
With Selection.InlineShapes(1).ConvertToShape
.Select
savePic Selection.ShapeRange(1), pic, fn
.ConvertToInlineShape
End With
Else
savePic Selection.ShapeRange(1), pic, fn
End If
End Sub
因为每天都要写报告，报告的模板公司已经规定，每次都要将大量的图片插入到已经建立好的图片中，要逐张调整尺寸适应表格的大小，浪费大量的时间。
请教楼主，能否编一组代码实现如下功能：选择照片插入到指定表格后，照片自动根据表格大小调整尺寸，谢谢，楼主！
Sub sadf()
h = Selection.Cells(1).Height
w = Selection.Cells(1).Width
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
Set p = Selection.InlineShapes.AddPicture(FileName:=.SelectedItems(1), SaveWithDocument:=True)
With p
.Width = w
.Height = h
End With
End With
End Sub
Sub 插入图片()
Dim myfile As FileDialog
Z = InputBox("请输入插入图片的宽度：", "厘米单位", 14) * 28.35
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "E:\"
If .Show = -1 Then
For Each fn In .SelectedItems
Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
pw1 = mypic.Width
ph1 = mypic.Height
mypic.Width = Z
mypic.Height = ph1 * Z / pw1
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
Selection.Text = Basename(fn) '函数取得文件名
Selection.EndKey
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
Next fn
Else
End If
End With
Set myfile = Nothing
End Sub
Function Basename(FullPath) '取得文件名
Basename = Left(CreateObject("Scripting.FileSystemObject").getfile(FullPath).Name, InStr(CreateObject("Scripting.FileSystemObject").getfile(FullPath).Name, ".") - 1)
End Function