Word中批量修改图片大小的方法

 

程序0：

Sub setpicsize()

    Dim i

    Dim Height, Weight

    Height = 300

    Weight = 200

    On Error Resume Next '忽略错误

    For i = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

            ActiveDocument.InlineShapes(i).Height = Height '设置图片高度为Height_px

            ActiveDocument.InlineShapes(i).Width = Weight '设置图片宽度Weight_px

    Next i

    For i = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片

            ActiveDocument.Shapes(i).Height = Height '设置图片高度为 Height_px

            ActiveDocument.Shapes(i).Width = Weight '设置图片宽度 Weight_px

    Next i

End Sub

  

程序1：查看每张图片的大小，方便后续的修改

Sub GetPhotoSize()

    Dim str As String

    Dim i

    For i = 1 To ActiveDocument.InlineShapes.Count

        'cstr:数字转字符串

        str = str + CStr(i) + ": "

        str = str + CStr(ActiveDocument.InlineShapes(i).Height) + " "

        str = str + CStr(ActiveDocument.InlineShapes(i).Width) + " "

        'chr(13)代表换行

        str = str + Chr(13)

    Next i

    MsgBox str

End Sub

 

 

 

程序2：修改第x张图片到第y张图片的大小(可以分成很多段)

Sub ModifyPhoto1()

    Dim i, x, y

    Dim Height, Weight

    Height = 80

    Weight = 100

    '修改第x张图片到第y张图片的大小

    x = 4

    y = 13

    On Error Resume Next '忽略错误

    For i = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

        If i >= x And i <= y Then

            ActiveDocument.InlineShapes(i).Height = Height '设置图片高度为Height_px

            ActiveDocument.InlineShapes(i).Width = Weight '设置图片宽度Weight_px

        End If

    Next i

 

    For i = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片

        If i > k Then

            ActiveDocument.Shapes(i).Height = Height '设置图片高度为 Height_px

            ActiveDocument.Shapes(i).Width = Weight '设置图片宽度 Weight_px

        End If

    Next i

End Sub

 

 

 

程序3：修改某一些图片的大小为某个值，修改另一些图片的大小为另外一个值(可以分成很多段，用boolean)

Sub ModifyPhoto2()

    '修改某一些图片的大小为某个值，修改另一些图片的大小为另外一个值

    Dim i, ans

    '100为图片最大数量，可以修改

    Dim vis(1 To 100) As Boolean

    Dim Height1, Weight1

    Dim Height2, Weight2

    Height1 = 80

    Weight1 = 100

    Height2 = 150

    Weight2 = 200

 

    On Error Resume Next '忽略错误

    For i = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

        vis(i) = False

    Next i

    'x(k)=true means modify the k_th photo

    For i = 4 To 13

        vis(i) = False

    Next i

    For i = 15 To 23

        vis(i) = False

    Next i

   

    For i = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

        If vis(i) = True Then

            ActiveDocument.InlineShapes(i).Height = Height1 '设置图片高度为Height_px

            ActiveDocument.InlineShapes(i).Width = Weight1 '设置图片宽度Weight_px

        Else

            ActiveDocument.InlineShapes(i).Height = Height2 '设置图片高度为Height_px

            ActiveDocument.InlineShapes(i).Width = Weight2 '设置图片宽度Weight_px

        End If

    Next i

End Sub

 

 

程序4：当图片大小大于(或小于)某个值时，修改为另外一个值。

效果：

 

 程序5：删去所有的图片，只剩下文字

Sub DeletePhoto()

    On Error Resume Next '忽略错误

    '两个for循环不能用同一个变量

    '因为photo1指的是所有在ActiveDocument.InlineShapes的元素

    '因为photo2指的是所有在ActiveDocument.Shapes的元素，二者被定义后不可改变

    Dim photo1, photo2 As Range

    For Each photo1 In ActiveDocument.InlineShapes

        photo1.Delete

    Next

    For Each photo2 In ActiveDocument.Shapes

        photo2.Delete

    Next

End Sub

效果(有可能剩下一些换行符)：

 

 程序6：在程序变通5只剩下文字的基础上，删去换行符

Sub changeCharacter()

    With Selection.Find

        '原来的内容

        .Text = "^p"

        '要修改成的内容，如果为""相当于删除

        .Replacement.Text = ""

        'wrap() 方法把每个被选元素放置在指定的内容或元素中。规定包裹(wrap)被选元素的内容。

        .Wrap = wdFindContinue

    End With

    '进行修改操作

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

 

(也可以做1个换行变成2个换行的操作，使文档看起来更舒服：.Text="^p"　　.Replacement.Text="^p"）

 

 程序7：删去所有的文字，只剩下图片

Sub DeleteCharacter()

    Dim word As Range

    For Each word In ActiveDocument.Words

        'NoProofing:如此如果拼写和语法检查程序忽略指定的文本。如果仅有某些指定的文本将NoProofing属性设置为True ，则返回wdUndefined 。读/写长。

        '图片值为-1，文字值为0

        If word.NoProofing = 0 Then

            word.Delete

        End If

    Next word

End Sub

 以下是错误程序：

'With Selection.Find

    '    .Text = True

    '    .Replacement.Text = ""

    '    .Wrap = wdFindContinue

    'End With

    'Selection.Find.Execute Replace:=wdReplaceAll

 

 

    'Dim ch As Range

    'For Each ch In ActiveDocument.Words

    '    ch.Delete

    'Next

 

 

  程序8：第x张图片到第y张图片改变顺序，变成第y张图片(原来)到第x张图片(原来)

 

 程序9：把所有的图片保存在一个文件夹下，或转移图片到另外一个word文档

 

 程序10：把某些字加粗和改变颜色

Sub ModifyCharacter()

    Dim str As String

    str = "图片"

    With Selection.Find

        .Text = str

        .Replacement.Font.Bold = True

        .Replacement.Font.Color = wdColorRed

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

程序11：将所有图片大小设置成与第一张图片的大小相同

Sub setpicsize()

    Dim i

    Dim Height, Weight

    Height =  ActiveDocument.InlineShapes(1).Height

    Weight = ActiveDocument.InlineShapes(1).Width

    On Error Resume Next '忽略错误

    For i = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

            ActiveDocument.InlineShapes(i).Height = Height '设置图片高度为Height_px

            ActiveDocument.InlineShapes(i).Width = Weight '设置图片宽度Weight_px

    Next i

    For i = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片

            ActiveDocument.Shapes(i).Height = Height '设置图片高度为 Height_px

            ActiveDocument.Shapes(i).Width = Weight '设置图片宽度 Weight_px

    Next i

End Sub 

附录１: Word通配符查找详解（Wildcards） 

 

通配符使用规则如下： 

任意单个字符 键入 ? 

例如，s?t 可查找“sat”和“set”。 

 

任意字符串 键入 * 

例如，s*d 可查找“sad”和“started”。 

 

单词的开头 键入<</span>

例如，<(inter) 查找“interesting”和“intercept”，但不查找“splintered”。 

 

单词的结尾 键入>

例如，(in)>查找“in”和“within”，但不查找“interesting”。 

 

指定字符之一 键入 [ ] 

例如，w[io]n 查找“win”和“won”。 

 

指定范围内任意单个字符 键入 [-] 

例如，[r-t]ight 查找“right”和“sight”。必须用升序来表示该范围。 

 

中括号内指定字符范围以外的任意单个字符 键入[!x-z] 

例如，t[!a-m]ck 查找“tock”和“tuck”，但不查找“tack”和“tick”。 

 

n 个重复的前一字符或表达式 键入 {n} 

例如，fe{2}d 查找“feed”，但不查找“fed”。 

 

至少 n 个前一字符或表达式 键入 {n,} 

例如，fe{1,}d 查找“fed”和“feed”。 

 

n 到 m 个前一字符或表达式 键入 {n,m} 

例如，10{1,3} 查找“10”、“100”和“1000”。

 

一个以上的前一字符或表达式 键入 @ 

例如，lo@t 查找“lot”和“loot”。 

 

特殊意义的字符 键入 \ 

例如，f[\?]t 查找“f?t”   ( )

对查询结果没有影响，是一个替换时分组的概念 例子：

用\2 \1替换(John) (Smith)，得到结果Smith John  即\1代表John，\2代表Smith

(来自网络)

 

 

附录2：自己写的一个设计；word中一个图片高度，宽度按照原有尺寸自动变形。

Sub setpicsize()

    Dim str As String

    Dim i

    Dim Height, Weight, ratio

    Height = 50   '设定图片的高度  px

    For i = 1 To ActiveDocument.InlineShapes.Count

        'cstr:数字转字符串

        Weight = ActiveDocument.InlineShapes(i).Width

        ratio = ActiveDocument.InlineShapes(i).Height / ActiveDocument.InlineShapes(i).Width

        ActiveDocument.InlineShapes(i).Height = Height '设置图片高度为Height_px

        ActiveDocument.InlineShapes(i).Width = Weight / ratio '设置图片宽度 Weight_px

    Next i

    For i = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片

        Weight = ActiveDocument.Shapes(i).Width

        ratio = ActiveDocument.Shapes(i).Height / ActiveDocument.InlineShapes(i).Width

        ActiveDocument.Shapes(i).Height = Height '设置图片高度为 Height_px

        ActiveDocument.Shapes(i).Width = Weight / ratio '设置图片宽度Weight_px

    Next i

End Sub