AW: Tabellenausschnitt als Bild in Image einer UF
03.07.2010 09:01:14
Nepumuk
Hallo Rainer,
unter Excel 2007 füge ich das Charts erst als Bild in eine Tabelle und dann diese Bild ins Userform.
In die selbe Tabelle einfügen ist mir zu Umständlich, denn anders als in den Vorgängerversionen von Excel 2007 bekommt ein eingefügtes Shape nicht automatisch den höchsten Index, sondern irgendeinen dazwischen. Ich hab's noch nicht ganz durchschaut, aber anscheinend werden da "Type-Groups" gebildet. Daher ist das nicht mehr so eindeutig wie früher. Weiß der Teufel an welcher geistiger Umnachtung der verantwortliche Programmierer litt.
Beispiel:
Option Explicit
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As PIC_DESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPictureDisp) As Long
Declare Function CopyImage Lib "user32.dll" ( _
ByVal handle As Long, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PIC_DESC
lngSize As Long
lngType As Long
lnghPic As Long
lnghPal As Long
End Type
Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"
Private Function Paste_Picture() As IPictureDisp
Dim lngReturn As Long, lngCopy As Long, lngPointer As Long
If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
lngReturn = OpenClipboard(Application.hWnd)
If lngReturn > 0 Then
lngPointer = GetClipboardData(CF_BITMAP)
lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call CloseClipboard
If lngPointer <> 0 Then Set Paste_Picture = Create_Picture(lngCopy, 0&, CF_BITMAP)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) As IPictureDisp
Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
With udtID_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
With udtPicInfo
.lngSize = Len(udtPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = lnghPal
End With
Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
Set Create_Picture = objPicture
End Function
Public Sub Show_Sheet()
Dim objPicture As IPictureDisp
Dim objWorksheet As Worksheet
Call EmptyClipboard
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Tabelle1.ChartObjects(1).Copy
Set objWorksheet = Worksheets.Add
objWorksheet.PasteSpecial Format:="Bild (JPEG)"
objWorksheet.Shapes(1).CopyPicture _
Appearance:=xlScreen, Format:=xlBitmap
Set objPicture = Paste_Picture
objWorksheet.Delete
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Not objPicture Is Nothing Then
UserForm1.Image1.Picture = objPicture
Else
MsgBox "Error - Chart can't show in Userform", vbCritical, "Error"
End If
Tabelle1.Range("A151:E159").CopyPicture _
Appearance:=xlScreen, Format:=xlBitmap
Set objPicture = Paste_Picture
If Not objPicture Is Nothing Then
UserForm1.Image2.Picture = objPicture
Else
MsgBox "Error - Sheet can't show in Userform", vbCritical, "Error"
End If
UserForm1.Show
End Sub
Gruß
Max