[求助]恳请帮我修改下面的VBA代码

ssq1109

以下这段代码是受到下面链接中代码的启发编出的,意在批量提取文档中的表格为增强型图元文件(如table001.emf等),并在原表格的前面加一标记(如“table001.emf,……”)。现有3个问题: http://club.excelhome.net/dispbbs.asp?BoardID=23&ID=155054&replyID=&skin=0 1.这段代码在我的机上(WIN2K+OFFICE 2003 SP2)能正常运行,但在另一机上(WIN XP+OFFICE XP)上不能在c:\temp下提出图片,我百思不解。 2.我本来希望将附件中文档test.doc运行后得到test1.doc的结果(即所加标记在表格前面),但它却得到了test2.doc的结果(即所加标记在表格的第一个单元格中)。能否通过修改代码使其得到test1.doc的结果(即所加标记在表格前面)。 3.所得表格的图片(见附件)下方有我不希望看到的空白(有些在左方、右方也有),能否通过修改代码去掉这些空白 Public BeforeShapes As Integer Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hDC As Long) As Long Sub GetTables() Dim i As Table, Bmpname As String For Each i In ActiveDocument.Tables i.Select Selection.Copy a = a + 1 Bmpname = "c:\temp\table" & VBA.Format(a, "000" & ".emf") OpenClipboard 0 DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), Bmpname) ' 14 CloseClipboard i.Range.InsertBefore "table" & VBA.Format(a, "000" & ".emf") & Chr(13) Next End Sub tFpCYN02.rar (10.55 KB, 下载次数: 20)

2006-3-24 09:00 上传

点击文件名下载附件
[求助]恳请帮我修改下面的VBA代码

守柔

先试一下这个：

Sub Example()
Dim i As Table, myRange As Range, A As Integer
With Me
For Each i In .Tables
A = A + 1
Set myRange = .Range(i.Range.Start, i.Range.Start)
If myRange.Start = 0 Then
myRange.Select
Selection.SplitTable
myRange.InsertAfter "table" & VBA.Format(A, "000" & ".emf")
Else
Set myRange = .Range(i.Range.Start - 1, i.Range.Start - 1)
myRange.InsertAfter Chr(13) & "table" & VBA.Format(A, "000" & ".emf")
End If
Next
End With
End Sub

ssq1109

非常谢谢守柔大侠，果然解决了我很想解决的一个问题。只是在我家里的老爷机（Win98＋Office2000）上“With Me”一句通不过，我将它改成With ActiveDocument后能PASS。

我是这样提图的，先插入一个模块，将下面的代码写进去，Sub前面的应该是引用的API函数，这样在我的老爷机上也能将表格提到c:\temp上（先须有此目录），我就是不明白为何在我单位的一个WinXP+OfficeXP上反而不能提图（在原文档中加标记仍然可以）？！还有更奇怪的是我在单位的两个硬件配置完全相同的电脑且均为Win2000+Office2003，只是一台的Office2003是SP2而另一台不是SP2（原始安装文件相同，前者更新为SP2，后者未更新过），2个机上均能得到表格的EMF图，但我同样用“Advanced Batch Converter3.80绿色版”将它们转换成TIF图（参数设置都完全相同），前者（SP2机）所得的TIF图非常清晰，后者很不清晰（尺寸大小相同时前者为600dpi，后者为96dpi），我今天在WIN98＋OFFICE2000上所得的TIF图也不清晰，分辨率也为96dpi。

至于表格边白问题，我后来想了一下，应该不可能通过代码解决，因为我将表格单独复制粘贴到CorelDraw 11 中文版的一个新建页面中，这个表格对象仍有边白，和我提取的EMF图的边白是一样的。

Public BeforeShapes As Integer

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long

Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function SetEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long

Sub GetTables()

Dim i As Table, myRange As Range, A As Integer

With ActiveDocument

For Each i In .Tables

i.Select

Selection.Copy

A = A + 1

Emfname = "c:\temp\table" & VBA.Format(A, "000" & ".emf")

OpenClipboard 0

DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), Emfname)

CloseClipboard

Set myRange = .Range(i.Range.Start, i.Range.Start)

If myRange.Start = 0 Then

myRange.Select

Selection.SplitTable

myRange.InsertAfter "table" & VBA.Format(A, "000" & ".emf")

Else

Set myRange = .Range(i.Range.Start - 1, i.Range.Start - 1)

myRange.InsertAfter Chr(13) & "table" & VBA.Format(A, "000" & ".emf")

End If

' i.Delete '删除表格（根据需要决定是否用此句）

Next

End With

End Sub