currentchart.export兼容性excel 2010 vs 2003

我需要从excel导出图表。我在Excel 2010中做到了，工作得很好，但是，在Excel 2003中也需要该应用程序。当我在2003年使用相同的代码时，图像不能正确导出（它是一个圆环图，并且“部分”没有很好地嵌入）。currentchart.export兼容性excel 2010 vs 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

来源

2012-07-09 Ane Hervías Caballero

会发生什么事，当你将其导出为JPG（基利安谢谢！的解决方案）？ – 2012-07-09 12:00:43

我试图导出为jpg和gif，但发生同样的错误。我认为这个问题是由于是一个组图像（我尝试导出每个图像，并且excel是正确的），但是我需要组图像... – 2012-07-09 13:35:30

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

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

来源

2012-07-10 08:58:47

currentchart.export兼容性excel 2010 vs 2003

回答

相关问题