[求助]再次请教守版主

huposhhy

在word文档中有两个表格，第二个表格的第三个单元格里即有文字又有图片，我想建立一个按钮，点击后将单元格中的内容建立一个新的word文档，新的word文档中不出现表格，请问如何实现？

huposhhy

Private Sub CommandButton1_Click() Set oTable = ActiveDocument.Tables(2) For Each aCell In oTable.Rows(1).Cells

Set myRange = ActiveDocument.Range(Start:=aCell.Range.Start, _ End:=aCell.Range.End - 1) Set fs = CreateObject("scripting.FileSystemObject") Set a = fs.OpenTextFile("d:\新文档.doc", 2, True) a.Write (myrange.Text) a.Close Next

End Sub

上面是我找到的一段代码，但是运行后生成的新DOC文档中只有文字而没有图形，请多多指教。

守柔

请参:

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-3-28 5:22:48 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub Example() Dim aTable As Table, aCell As Cell, Doc As Document, MyString As String Set Doc = Documents.Add '新建文档 With ThisDocument '本文档中 For Each aTable In .Tables '所有表格中循环 For Each aCell In aTable.Range.Cells '表格的所有单元格中循环 MyString = MyString & aCell.Range '注意此处未去除回车符 If aCell.Range.ShapeRange.Count = 1 Then '此处指单元格中含有非嵌入式图片 aCell.Range.ShapeRange(1).Select '选定 Selection.Copy '复制 Doc.Activate '激活DOC,以便将SELECTION对象移到DOC中 End If Next Next End With Selection.InsertAfter MyString '将文本部分内容插入 Selection.Paste '粘贴图片 End Sub '----------------------

huposhhy

非常感谢！不过又出现新的问题了。[em06]

WuO7IM2V.rar (19.49 KB, 下载次数: 13)

2005-3-29 00:11 上传

点击文件名下载附件
[求助]再次请教守版主

守柔

请参：（早知是这样，就方便了！）

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-3-29 07:07:15 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub Again() 'PassWord请自行根据需要加入 Dim aTable As Table, aCell As Cell, Doc As Document, MyString As String Dim TF As Boolean Set Doc = Documents.Add '新建文档 With ThisDocument '本文档中 If .ProtectionType <> wdNoProtection Then: TF = True: .Unprotect Password:="" For Each aTable In .Tables '所有表格中循环 For Each aCell In aTable.Range.Cells '表格的所有单元格中循环 aCell.Range.Copy With Selection .PasteAndFormat (wdSingleCellText) '将单一单元格粘贴为文本 .InsertAfter Chr(13) .EndKey wdStory End With Next Next If TF = True Then .Protect wdAllowOnlyFormFields, , "" End With End Sub

huposhhy

感谢,正在测试,没有发现问题

huposhhy

再次真诚感谢守老师对学生的细心指导，学生今天又有新的问题了：还是关于表格单元格的内容保存为Word文档的问题。

我想每次以不同的文件名保存于同一文件夹，比如第一次我用1，接下来用2、3、4……，每次保存时都会自动在最大值后加“1”，并且如果我将其中的一个文件删除了，比如“3”，那么下次保存时它会自动保存为“3”，请问怎样才能实现这个功能？由于学生的基础较差希望老师在百忙之中给以详细的讲解。

守柔

请参：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-4-5 05:12:35 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub Example() Dim MyFile As Object, MyFolder As Object, MyFolders As Object, F As Object Dim FileCount As Integer, i As Integer, FileName As String Set MyFolders = CreateObject("Scripting.FileSystemObject") '创建系统文件 '获得指定系统文件下的文件夹对象 Set MyFolder = MyFolders.GetFolder("E:\Test") '此处可更改路径,注意反斜杠 '获得指定文件夹下的实际WORD文件总数(去除了临时WORD文件) For Each F In MyFolder.Files If F.Type = "Microsoft Word Document" And VBA.InStr(F.Name, "~$") = 0 Then ' MsgBox F.Name FileCount = FileCount + 1 '计数 End If Next For i = 1 To FileCount '在指定文件数量中循环 FileName = "E:\Test\" & i & ".Doc" '定义一个变量为文件名 If MyFolders.FileExists(FileName) = False Then '如果删除了某一个文件,则找不到 MsgBox "未找到" & FileName & "文件!" '提示 ActiveDocument.SaveAs FileName '以该文件名另存为 Exit Sub '退出程序 End If Next ActiveDocument.SaveAs "E:\Test\" & FileCount + 1 & ".Doc" '延续编号保存 End Sub '----------------------

huposhhy

正在学习，感谢守老师，注意身体。