批量设置WORD文件图片大小（无密码版）

banjinjiu · 发表于 2014-7-11 14:27

Sub setpicture()
Dim n
On Error Resume Next
For n = 1 To ActiveDocument.InlineShapes.Count
ActiveDocument.InlineShapes(n).Height = 153
ActiveDocument.InlineShapes(n).Width = 243
Next n
For n = 1 To ActiveDocument.Shapes.Count
ActiveDocument.Shapes(n).Height = 153
ActiveDocument.Shapes(n).Width = 243
Next n
End Sub

复制代码

Sub setpicsize1() '设置图片大小
Dim n '图片个数
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为400px
ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度300px
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
ActiveDocument.Shapes(n).Height = 400 '设置图片高度为400px
ActiveDocument.Shapes(n).Width = 300 '设置图片宽度300px
Next n
End Sub

复制代码

Sub Macro()
Mywidth = 10 '10为图片宽度（厘米）
Myheigth = 10 '10为图片高度（厘米）
For Each iShape In ActiveDocument.InlineShapes
iShape.Height = 28.345 * Myheigth
iShape.Width = 28.345 * Mywidth
Next iShape
End Sub

复制代码

Sub setpicsize2() '设置图片大小
Dim n '图片个数
Dim picwidth
Dim picheight
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
picheight = ActiveDocument.InlineShapes(n).Height
picwidth = ActiveDocument.InlineShapes(n).Width
ActiveDocument.InlineShapes(n).Height = picheight * 1.1 '设置高度为1.1倍
ActiveDocument.InlineShapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
picheight = ActiveDocument.Shapes(n).Height
picwidth = ActiveDocument.Shapes(n).Width
ActiveDocument.Shapes(n).Height = picheight * 1.1 '设置高度为1.1倍
ActiveDocument.Shapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍
Next n
End Sub

复制代码

Sub test()
ActiveDocument.InlineShapes(1).Select '
With Selection
If .Type = wdSelectionInlineShape Then
Set myShape = .InlineShapes(1).ConvertToShape
With myShape
.ScaleHeight 0.6, True
.ScaleWidth 0.6, True
End With
End If
End With
End Sub

复制代码

使用excel文件打开word文件的方法，代码在excel里

'移除VBA编码保护
Sub MoveProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件（*doc & *doct & *docm）,*.doc;*.doct;*doctm", ,"VBA破解")
If FileName = CStr(False) Then
Exit Sub
Else
VBAPassword FileName, False
End If
End Sub
'设置VBA编码保护
Sub SetProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("word文件（*doc & *doct & *docm）,*.doc;*.doct;*doctm", ,"VBA破解")
If FileName = CStr(False) Then
Exit Sub
Else
VBAPassword FileName, True
End If
End Sub
Private Function VBAPassword(FileName As String,Optional Protect As Boolean = False)
If Dir(FileName) = "" Then
Exit Function
Else
FileCopy FileName, FileName & ".bak"
End If
Dim GetData As String * 5
Open FileName For Binary As #1
Dim CMGs As Long
Dim DPBo As Long
For i = 1 To LOF(1)
Get #1, i, GetData
If GetData = "CMG=""" Then CMGs = i
If GetData = "[Host" Then DPBo = i - 2: Exit For
Next
If CMGs = 0 Then
CMGs = 0
‘MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
Exit Function
End If
If Protect = False Then
Dim St As String * 2
Dim s20 As String * 1
'取得一个0D0A十六进制字串
Get #1, CMGs - 2, St
'取得一个20十六制字串
Get #1, DPBo + 16, s20
'替换加密部份机码
For i = CMGs To DPBo Step 2
Put #1, i, St
Next
'加入不配对符号
If (DPBo - CMGs) Mod 2 <> 0 Then
Put #1, DPBo + 1, s20
End If
MsgBox "文件解密成功......", 32, "提示"
Else
Dim MMs As String * 5
MMs = "DPB="""
Put #1, CMGs, MMs
MsgBox "对文件特殊加密成功......", 32, "提示"
End If
Close #1
End Function

复制代码

转别人的代码，继续整理。

tangqingfu · 发表于 2014-7-16 07:44

学习ing，谢谢楼主的分享！

落梅花 · 发表于 2014-7-15 20:38

收藏学习，谢谢分享。

lintf · 发表于 2021-2-11 15:47

学习了，谢谢分享

		自动登录	找回密码
密码			免费注册

[分享] 批量设置WORD文件图片大小（无密码版）