删除word文件中所有图片，删除不彻底，帮忙看看。

oceanwinder

以下为代码：

1. Sub Testdelpics()
   
2.     Dim MyName, Dic, Did, i, MyFileName
   
3.        'On Error Resume Next
   
4.    
   
5.     lj = "F:\work\京韩四季拍卖\test"
   
6.    
   
7.    
   
8.     Set objFolder = Nothing
   
9.     Set objShell = Nothing
   
10.   
    
11.     t = Time
    
12.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
13.     Set Did = CreateObject("Scripting.Dictionary")
    
14.     Dic.Add (lj), ""
    
15.     i = 0
    
16.     Do While i < Dic.Count
    
17.         ke = Dic.Keys   '开始遍历字典
    
18.         MyName = Dir(ke(i), vbDirectory)    '查找目录
    
19.         Do While MyName <> ""
    
20.             If MyName <> "." And MyName <> ".." Then
    
21.                 If (GetAttr(ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
22.                     Dic.Add (ke(i) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
23.                 End If
    
24.             End If
    
25.             MyName = Dir    '继续遍历寻找
    
26.         Loop
    
27.         i = i + 1
    
28.     Loop
    
29.    
    
30.     For Each ke In Dic.Keys
    
31.         MyFileName = Dir(ke & "*.doc*")
    
32.         Do While MyFileName <> ""
    
33.             Did.Add (ke & MyFileName), ""
    
34.             MyFileName = Dir
    
35.         Loop
    
36.     Next
    
37.    
    
38.     Dim App, WrdDoc As Document
    
39.     Set App = CreateObject("Word.Application")
    
40.    
    
41.     '打开这个Word文件！
    
42.    
    
43.     For Each ke In Did.Keys
    
44.    
    
45.         'Debug.Print (Ke)
    
46.         
    
47.         On Error Resume Next
    
48.         If Len(Documents(ke).Name) > 0 Then
    
49.             'Debug.Print (ke)
    
50.             'Debug.Print (Err.Number)
    
51.             If Err.Number <> 0 Then
    
52.                 Set WrdDoc = App.Documents.Open(ke)
    
53.             Else:
    
54.                 Set WrdDoc = Documents(ke)
    
55.             End If
    
56.         End If
    
57.         'Debug.Print (WrdDoc.Name)
    
58.         Call delPics(WrdDoc)
    
59.         
    
60.     Next
    
61. End Sub
    
62. 
    
63. Function delPics(curdoc As Document)
    
64.    
    
65.     Debug.Print (curdoc.Name)
    
66.     'Debug.Print ("delPics")
    
67. '
    
68.      Dim nGrap As InlineShape
    
69.      Dim nShap As Shape
    
70.    
    
71.      For Each nGrap In curdoc.InlineShapes   '删除图片
    
72.          nGrap.Select
    
73.          nGrap.Delete
    
74.      Next
    
75.    
    
76.      For Each nShap In curdoc.Shapes         '删除绘图
    
77.          
    
78.          nShap.Delete
    
79.      Next
    
80.      curdoc.Close (True)
    
81. End Function

复制代码

浮于上方的图片好象删除不了，有时候又是浮于文字下方的图片删除不了，我该怎样修改呢？

limonet

Sub DeleteShapes()
    Dim i%
    For i = 1 To ActiveDocument.InlineShapes.Count
        ActiveDocument.InlineShapes(1).Delete
    Next
    For i = 1 To ActiveDocument.Shapes.Count
        ActiveDocument.Shapes(1).Delete
    Next
End Sub

daibao88

Sub DeleteShape()
    Dim i As Integer, n As Integer
    If ActiveDocument.Shapes.Count + ActiveDocument.InlineShapes.Count = 0 Then Exit Sub
    n = ActiveDocument.Shapes.Count
    For i = n To 1 Step -1
        Set sp = ActiveDocument.Shapes(i)
        If sp.Type = msoPicture Then sp.Delete
    Next
    n = ActiveDocument.InlineShapes.Count
    For i = n To 1 Step -1
        Set sp = ActiveDocument.InlineShapes(i)
        If sp.Type = wdInlineShapePicture Then sp.Delete
    Next
End Sub