currentchart.export兼容性excel 2010 vs 2003

Question

我需要從excel導出圖表。我在Excel 2010中做到了，工作得很好，但是，在Excel 2003中也需要該應用程序。當我在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 

Answer 1

我已經找到其他的解決辦法...你可以將圖像複製爲位圖，然後從剪貼板中保存。

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功能http://www.vbaexpress.com/forum/archive/index.php/t-6046.html

'############################################## 
'### 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