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

banjinjiu

1. Sub setpicture()
   
2. Dim n
   
3. On Error Resume Next
   
4. For n = 1 To ActiveDocument.InlineShapes.Count
   
5. ActiveDocument.InlineShapes(n).Height = 153
   
6. ActiveDocument.InlineShapes(n).Width = 243
   
7. Next n
   
8. For n = 1 To ActiveDocument.Shapes.Count
   
9. ActiveDocument.Shapes(n).Height = 153
   
10. ActiveDocument.Shapes(n).Width = 243
    
11. Next n
    
12. End Sub

复制代码

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

复制代码

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

复制代码

1. Sub setpicsize2() '设置图片大小
   
2. Dim n '图片个数
   
3. Dim picwidth
   
4. Dim picheight
   
5. On Error Resume Next '忽略错误
   
6. For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
   
7. picheight = ActiveDocument.InlineShapes(n).Height
   
8. picwidth = ActiveDocument.InlineShapes(n).Width
   
9. ActiveDocument.InlineShapes(n).Height = picheight * 1.1 '设置高度为1.1倍
   
10. ActiveDocument.InlineShapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍
    
11. Next n
    
12. For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
    
13. picheight = ActiveDocument.Shapes(n).Height
    
14. picwidth = ActiveDocument.Shapes(n).Width
    
15. ActiveDocument.Shapes(n).Height = picheight * 1.1 '设置高度为1.1倍
    
16. ActiveDocument.Shapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍
    
17. Next n
    
18. End Sub

复制代码

1. Sub test()
   
2. ActiveDocument.InlineShapes(1).Select '
   
3. With Selection
   
4. If .Type = wdSelectionInlineShape Then
   
5. Set myShape = .InlineShapes(1).ConvertToShape
   
6. With myShape
   
7. .ScaleHeight 0.6, True
   
8. .ScaleWidth 0.6, True
   
9. End With
   
10. End If
    
11. End With
    
12. End Sub

复制代码

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

1. 
   
2. '移除VBA编码保护
   
3. Sub MoveProtect()
   
4. Dim FileName As String
   
5. FileName = Application.GetOpenFilename("Excel文件（*doc & *doct & *docm）,*.doc;*.doct;*doctm", ,"VBA破解")
   
6. If FileName = CStr(False) Then
   
7. Exit Sub
   
8. Else
   
9. VBAPassword FileName, False
   
10. End If
    
11. End Sub
    
12. '设置VBA编码保护
    
13. Sub SetProtect()
    
14. Dim FileName As String
    
15. FileName = Application.GetOpenFilename("word文件（*doc & *doct & *docm）,*.doc;*.doct;*doctm", ,"VBA破解")
    
16. If FileName = CStr(False) Then
    
17. Exit Sub
    
18. Else
    
19. VBAPassword FileName, True
    
20. End If
    
21. End Sub
    
22. Private Function VBAPassword(FileName As String,Optional Protect As Boolean = False)
    
23. If Dir(FileName) = "" Then
    
24. Exit Function
    
25. Else
    
26. FileCopy FileName, FileName & ".bak"
    
27. End If
    
28. Dim GetData As String * 5
    
29. Open FileName For Binary As #1
    
30. Dim CMGs As Long
    
31. Dim DPBo As Long
    
32. For i = 1 To LOF(1)
    
33. Get #1, i, GetData
    
34. If GetData = "CMG=""" Then CMGs = i
    
35. If GetData = "[Host" Then DPBo = i - 2: Exit For
    
36. Next
    
37. If CMGs = 0 Then
    
38. CMGs = 0
    
39. ‘MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
    
40. Exit Function
    
41. End If
    
42. If Protect = False Then
    
43. Dim St As String * 2
    
44. Dim s20 As String * 1
    
45. '取得一个0D0A十六进制字串
    
46. Get #1, CMGs - 2, St
    
47. '取得一个20十六制字串
    
48. Get #1, DPBo + 16, s20
    
49. '替换加密部份机码
    
50. For i = CMGs To DPBo Step 2
    
51. Put #1, i, St
    
52. Next
    
53. '加入不配对符号
    
54. If (DPBo - CMGs) Mod 2 <> 0 Then
    
55. Put #1, DPBo + 1, s20
    
56. End If
    
57. MsgBox "文件解密成功......", 32, "提示"
    
58. Else
    
59. Dim MMs As String * 5
    
60. MMs = "DPB="""
    
61. Put #1, CMGs, MMs
    
62. MsgBox "对文件特殊加密成功......", 32, "提示"
    
63. End If
    
64. Close #1
    
65. End Function

复制代码

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

tangqingfu

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

落梅花

收藏学习，谢谢分享。

lintf

学习了，谢谢分享