Thomas Risi Softwareentwicklung
Addins - Datenbanklösungen - Komponenten - RTDServer - WebServices
Chart2Image (2)
Immer wieder Thema in den diversen Foren ... Wie stelle ich ein Diagramm einer Tabelle in einer UserForm dar?
Hier eine API-Lösung, die die Charts zuerst in das Clipboard und dann in eine UserForm lädt.
Quellcode für eine UserForm mit zwei CommandButtons und einem Image-Control ...
Option Explicit
Private Declare Function IIDFromString Lib "ole32.dll" ( _
ByVal lpsz As String, _
ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As PICTDESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPictureDisp) As Long
Private 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 PICTDESC
cbSizeOfStruct As Long
picType As Long
hgdiObj As Long
hPalOrXYExt As Long
End Type
Private Const S_OK = 0&
Private Const PICTYPE_BITMAP = 1&
Private Const CF_BITMAP = 2&
Private Const IMAGE_BITMAP = 0&
Private Const LR_COPYRETURNORG = 4&
Private Sub CommandButton1_Click()
Call ChartFromClipboard(Tabelle1.ChartObjects(1))
End Sub
Private Sub CommandButton2_Click()
Call ChartFromClipboard(Tabelle1.ChartObjects(2))
End Sub
Public Sub ChartFromClipboard(chrt As Excel.ChartObject)
Call EmptyClipboard
chrt.Chart.CopyPicture Appearance:=xlScreen, Format:=xlBitmap, Size:=xlScreen
Me.Image1.Picture = PictureFromClipboard
End Sub
Private Function PictureFromClipboard() As IPictureDisp
Const IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Dim hCopy As Long, hBitmap As Long, hResult As Long
Dim hPicture As IPictureDisp
Dim tPictDesc As PICTDESC, piid As GUID
If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
If OpenClipboard(Application.hWnd) <> 0 Then
hBitmap = GetClipboardData(CF_BITMAP)
If hBitmap <> 0 Then
hCopy = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call CloseClipboard
hResult = IIDFromString(StrConv(IPicture, vbUnicode), piid)
If hResult = S_OK Then
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = PICTYPE_BITMAP
.hgdiObj = hCopy
.hPalOrXYExt = 0&
End With
Call OleCreatePictureIndirect(tPictDesc, piid, 0&, hPicture)
Set PictureFromClipboard = hPicture
End If
End If
End If
End If
End Function
© 2001 -
by Thomas Risi