currentchart.export兼容性excel 2010与2003

我需要从excel中导出图表。我在Excel2010中做的很好，但是在Excel2003中也需要这个应用程序。当我在2003年使用相同的代码时，图像没有正确导出（它是一个甜甜圈图，“部分”没有很好地嵌入）

这是我正在使用的代码：

Sheets("SLA Chart").Select
ActiveSheet.Shapes.Range(Array("Dibujo")).Select
Selection.Copy
Range("H5").Select
ActiveSheet.Pictures.Paste.Select
Selection.Name = "imagen"
Selection.Copy
Charts.Add
ActiveChart.Paste
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 282
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 213
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 40
Selection.ShapeRange.ScaleWidth 0.75, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft 275
Selection.ShapeRange.IncrementTop 175 'I can see here the image right
archivo = ThisWorkbook.Path & Application.PathSeparator _
& "temp.gif"
ActiveChart.Export Filename:=archivo, FilterName:="GIF" 'The image is not well embedded
Application.DisplayAlerts = False
ActiveChart.Delete
Application.DisplayAlerts = True
Sheets("SLA Chart").Select
ActiveSheet.Shapes.Range(Array("imagen")).Delete

---

我找到了其他的解决办法。。。您可以将图像复制为位图，然后将其从剪贴板保存

Sheets("SLA Chart").Select
'ActiveSheet.Shapes.Range(Array("Cuentakilometros")).Select
ActiveSheet.Shapes(3).CopyPicture
ActiveSheet.Paste
imagen = Selection.Name
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Clip2File

archivo = ThisWorkbook.Path & Application.PathSeparator & "\temp.bmp"
ActiveSheet.Shapes.Range(Array(imagen)).Delete

其中Clip2file是从页面获取的函数 （Killian的解决方案谢谢！！）

'##############################################
“####粘贴到标准模块-调用clip2文件###
'##################################################
'检查剪贴板中的位图
'如果找到，则从
'剪贴板内容并将其保存到文件中
'代码需要引用“OLE自动化”类型库
'此模块中的代码主要来自_
Stephen Bullen Excel页面上的PatsePicture示例_
' - http://www.bmsltd.ie/Excel/Default.htm
'Windows API函数声明
私有声明函数IsClipboardFormatAvailable Lib“user32”_
（ByVal wFormat作为整数）长度相同
私有声明函数OpenClipboard Lib“user32”_
（ByVal hwnd As Long）一样长
私有声明函数GetClipboardData库“user32”_
（ByVal wFormat作为整数）长度相同
私有声明函数CloseClipboard Lib“user32”（长度为
专用声明函数OLEATEPICTUREINDIRECT Lib“olepro32.dll”（_
PicDesc作为uPicDesc，refid作为GUID，ByVal fPictureOwnsHandle_
只要，IPic作为IPicture）只要
私有声明函数CopyImage库“user32”（ByVal句柄_
只要_
ByVal un1为长，ByVal n1为长，ByVal n2为长_
ByVal un2 As Long）As Long
'我们需要的API格式类型
常数CF_位图=2
常量图像\u位图=0
Const LR_copyrurnorg=&H4
'声明UDT以存储IPacture OLE接口的GUID
专用类型GUID
数据1尽可能长
数据2作为整数
数据3作为整数
数据4（0到7）作为字节
端型
'声明UDT以存储位图信息
专用类型uPicDesc
大小与长度相同
尽可能长地打字
高性能集成电路
hPal只要
端型
子Clip2File（）
Dim strOutputPath作为字符串，oPic作为IPICUTREDISP
'获取保存位图的文件名
strOutputPath=thiswoolk.Path和Application.pathselector&“temp.bmp”
'从剪贴板中检索图片。。。
Set=GetClipPicture（）
'... 并将其保存到文件中
如果不是，那就什么都不是了
SavePicture，strOutputPath
“MsgBox”文件已保存：“&strOutputPath”
其他的
MsgBox“无法从剪贴板检索位图”
如果结束
端接头
函数GetClipPicture（）作为IPacture
变暗h为长，HPI为长，hPtr为长_
hPal尽可能长，hCopy尽可能长
'检查剪贴板是否包含位图
hpicavail=IsClipboardFormatAvailable（CF\u位图）
如果hpicavail为0，则
'获取对剪贴板的访问权限
h=打开剪贴板（0&）
如果h>0，则
'获取图像数据的句柄
hPtr=GetClipboardData（CF_位图）
hCopy=CopyImage（hPtr，图像\位图，0，0，LR\ U COPYRETURNORG）
'将剪贴板释放到其他程序
h=关闭剪贴板
“如果我们获得了图像的句柄，请将其转换为_
'一个图片对象并返回它
如果hPtr为0，则设置GetClipPicture=CreatePicture（hCopy_
0，CF_位图）
如果结束
如果结束
端函数
私有函数CreatePicture（ByVal hPic为长，ByVal hPal为长_
ByVal lPicType）作为IPacture
'IPacture需要引用“OLE自动化”
Dim r作为Long，uPicInfo作为uPicDesc，IID_IDispatch作为GUID_
IPic作为IPicture
'OLE图片类型
常量PICTYPE_位图=1
'创建接口GUID（用于IPacture接口）
用IID_IDispatch
.Data1=&H7BF80980
.Data2=&HBF32
.Data3=&H101A
.数据4（0）=&H8B
.数据4（1）=&HBB
.Data4（2）=&H0
.Data4（3）=&HAA
.Data4（4）=&H0
.数据4（5）=&H30
.数据4（6）=&HC
.Data4（7）=&HAB
以
'用必要的部分填充uPicInfo。
使用uPicInfo
.Size=Len（uPicInfo）结构的长度。
.Type=图片类型\位图的图片类型
.hPic=hPic的图像句柄。
.hPal=0'调色板句柄（如果是位图）。
以
'创建图片对象。
r=OleCreatePictureIndirect（uPicInfo，IID_IDispatch，True，IPic）
'返回新图片对象。
设置CreatePicture=IPic
端函数

导出到Jpg时会发生什么？我尝试导出到Jpg和gif，但出现了相同的错误。我认为问题是由于一个组图像（我尝试导出每个图像，excel做得很好），但我需要组图像。。。

'##############################################
 '### Paste into a standard module - call Clip2File ###
 '##################################################

' Checks the clipboard for a bitmap
' If found, creates a standard Picture object from the
' clipboard contetnts and saves it to a file
' The code requires a reference to the "OLE Automation" type library
' The code in this module has been derived primarily from _
' the PatsePicture sample on Stephen Bullen's Excel Page _
' - http://www.bmsltd.ie/Excel/Default.htm
'Windows API Function Declarations
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle _
As Long, IPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle _
As Long, _
ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
ByVal un2 As Long) As Long

'The API format types we need
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4


'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

 'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type

Sub Clip2File()

    Dim strOutputPath As String, oPic As IPictureDisp

     'Get the filename to save the bitmap to
    strOutputPath = ThisWorkbook.Path & Application.PathSeparator & "temp.bmp"

     'Retrieve the picture from the clipboard...
    Set oPic = GetClipPicture()

     '... and save it to the file
    If Not oPic Is Nothing Then
        SavePicture oPic, strOutputPath
        'MsgBox "File saved: " & strOutputPath
    Else
        MsgBox "Unable to retrieve bitmap from clipboard"
    End If
End Sub

Function GetClipPicture() As IPicture

    Dim h As Long, hpicavail As Long, hPtr As Long, _
    hPal As Long, hCopy As Long

     'Check if the clipboard contains a bitmap
    hpicavail = IsClipboardFormatAvailable(CF_BITMAP)

    If hpicavail <> 0 Then
         'Get access to the clipboard
        h = OpenClipboard(0&)
        If h > 0 Then
             'Get a handle to the image data
            hPtr = GetClipboardData(CF_BITMAP)
            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
             'Release the clipboard to other programs
            h = CloseClipboard
             'If we got a handle to the image, convert it into _
             'a Picture object and return it
            If hPtr <> 0 Then Set GetClipPicture = CreatePicture(hCopy, _
            0, CF_BITMAP)
        End If
    End If

End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, _
    ByVal lPicType) As IPicture

     ' IPicture requires a reference to "OLE Automation"
    Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, _
    IPic As IPicture

     'OLE Picture types
    Const PICTYPE_BITMAP = 1

     ' Create the Interface GUID (for the IPicture interface)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

     ' Fill uPicInfo with necessary parts.
    With uPicInfo
        .Size = Len(uPicInfo) ' Length of structure.
        .Type = PICTYPE_BITMAP ' Type of Picture
        .hPic = hPic ' Handle to image.
        .hPal = 0 ' Handle to palette (if bitmap).
    End With

     ' Create the Picture object.
    r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

     ' Return the new Picture object.
    Set CreatePicture = IPic

End Function