[已解决]感谢爱疯版主，问题已经解决。

eliterwholly

最佳答案

月排行榜 / 总排行榜

爱疯

2011-9-6 14:32

eliterwholly 发表于 2011-9-6 14:26
我也是03版：连续执行了三次，任务栏分别显示文档1、2、3、然后都结束了，可惜就是提取不了。

我看到版 ...

1. 
   
2. Sub test()    '将本document的所有shape对象中的文本，另存到文件夹abc中
   
3.     Dim doc As Document
   
4.     Dim shp As Shape
   
5.     Dim arr(1 To 9999) As String
   
6.     Dim i
   
7.     Dim p As String
   
8.     Dim n As String
   
9. 
   
10.     Application.ScreenUpdating = False
    
11.     Set doc = ThisDocument
    
12.     p = doc.Path & Application.PathSeparator
    
13.     n = "(副本)" & doc.Name    '重命名
    
14.     For Each shp In doc.Shapes
    
15.         i = i + 1
    
16.         arr(i) = shp.AlternativeText
    
17.     Next shp
    
18.     Set doc = Nothing
    
19. 
    
20.     Documents.Add
    
21.     For i = 1 To UBound(arr)
    
22.         Selection = arr(i)
    
23.         Selection.EndKey Unit:=wdStory
    
24.     Next i   
    
25.     If Dir(p & "\abc") = "" Then MkDir p & "\abc"
    
26.     With ActiveDocument
    
27.         .SaveAs p & "\abc" & n
    
28.         .Close
    
29.     End With
    
30. End Sub
    
31. 
    

复制代码

(, 下载次数: 27)

上传

点击文件名下载附件

跳转到最佳答案楼层

eliterwholly

感谢爱疯版主，问题已经解决。

爱疯

1. 
   
2. Sub test()    '将本document的所有shape对象中的文本，另存到新的document中。
   
3. 
   
4.     Dim doc As Document
   
5.     Dim shp As Shape
   
6.     Dim arr(1 To 9999) As String
   
7.     Dim i
   
8.     Dim p As String
   
9.     Dim n As String
   
10. 
    
11.     Application.ScreenUpdating = False
    
12.     Set doc = ThisDocument
    
13.     p = doc.Path & Application.PathSeparator
    
14.     n = "(副本)" & doc.Name    '重命名
    
15.     For Each shp In doc.Shapes
    
16.         i = i + 1
    
17.         arr(i) = shp.AlternativeText
    
18.     Next shp
    
19.     Set doc = Nothing
    
20. 
    
21.     Documents.Add
    
22.     For i = 1 To UBound(arr)
    
23.         Selection = arr(i)
    
24.         Selection.EndKey Unit:=wdStory
    
25.     Next i
    
26.     With ActiveDocument
    
27.         .SaveAs2 p & n
    
28.         .Close
    
29.     End With
    
30. 
    
31. End Sub

复制代码

word 宏求解002——测试用b.rar (20.91 KB, 下载次数: 2)

2011-9-6 13:15 上传

点击文件名下载附件
不知题意是不是要这样

eliterwholly

感谢爱疯版主，问题已经解决。

爱疯

03和07都是saveas
10只有saveas2


应该有什么版本，都可直接保存的办法的。
先看你saveas行不行

eliterwholly

感谢爱疯版主，问题已经解决。

爱疯

刚发现，10原来可以用saveas，只是提示菜单里没有。
就把saveas2改成saveas，看看

eliterwholly

感谢爱疯版主，问题已经解决。

爱疯

word 宏求解002——测试用c.rar (10.98 KB, 下载次数: 2)

2011-9-6 14:00 上传

点击文件名下载附件

代码不贴了，和上面一样，唯一变动就是saveas2，改为了saveas。

我用03试了，可以产生在当前路径下文件。

不知楼主要弹出什么？或时怎样效果？这样，可以吗

eliterwholly

感谢爱疯版主，问题已经解决。