![]() |
Tipp 0262
|
Diagramme auf UserForm anzeigen
|
 |
|
Autor/Einsender: Datum: |
|
Angie 24.04.2005 (Update) |
|
Entwicklungsumgebung: |
|
Excel 2000 |
|
|
Um ein Excel-Diagramm in einem Image-Steuerelement auf einer UserForm anzeigen zu
können, wird das Diagramm zunächst als Grafik im GIF-Format exportiert, und dann eingelesen.
|
Mit diesem Beispiel können bei Auswahl Diagramme, die in Tabellenblätter eingebettet sind,
im Image-Steuerelement angezeigt werden. Das Beispiel im Download ist ausführlich
kommentiert!
|
|
Code im Codebereich der UserForm |
|
|
Option Explicit
Private m_blnInit As Boolean
Private m_strTitle As String
Private m_strPath As String
Private m_wkbSrc As Workbook
Private m_wksSrc As Worksheet
Public Sub Init()
Me.Caption = m_strTitle
Me.cmdClose.Cancel = True
With Me.imgChart
.BorderStyle = fmBorderStyleNone
.PictureSizeMode = fmPictureSizeModeClip
.PictureAlignment = fmPictureAlignmentCenter
.SpecialEffect = fmSpecialEffectSunken
End With
Dim wks As Worksheet
For Each wks In m_wkbSrc.Worksheets
If wks.ChartObjects.Count > 0 Then
Me.cboWorksheets.AddItem wks.Name
End If
Next
Me.cboWorksheets.ListIndex = 0
m_blnInit = True
End Sub
Public Property Let gTitle(ByVal strTitle As String)
m_strTitle = strTitle
End Property
Public Property Let gTempPath(ByVal strPath As String)
m_strPath = strPath
End Property
Public Property Set gWorkbook(ByVal Wb As Workbook)
Set m_wkbSrc = Wb
End Property
Private Sub UserForm_Activate()
If Not m_blnInit Then Unload Me
End Sub
Private Sub UserForm_Terminate()
Set m_wksSrc = Nothing
Set m_wkbSrc = Nothing
End Sub
Private Sub cboWorksheets_Click()
Dim astrCharts() As String
Dim nChartsCnt As Long
Dim n As Long
Set m_wksSrc = m_wkbSrc.Worksheets(cboWorksheets.Text)
nChartsCnt = m_wksSrc.ChartObjects.Count
If nChartsCnt > 0 Then
ReDim astrCharts(0 To 1, 0 To nChartsCnt - 1)
For n = 1 To nChartsCnt
With m_wksSrc.ChartObjects(n)
astrCharts(0, n - 1) = .Name
If .Chart.HasTitle = True Then
astrCharts(1, n - 1) = .Chart.ChartTitle.Text
Else
astrCharts(1, n - 1) = .Name
End If
End With
Next n
With Me.cboCharts
.Clear
.ColumnCount = 2
.BoundColumn = 0
.ColumnWidths = "0"
.Column() = astrCharts
End With
Erase astrCharts
Me.cboCharts.ListIndex = 0
Else
Me.cboCharts.Clear
End If
End Sub
Private Sub cboCharts_Click()
Dim objChartObj As ChartObject
Dim strChartName As String
Dim strFileName As String
Dim sngChartHght As Single
Dim sngChartWdth As Single
With cboCharts
strChartName = .List(.ListIndex, .BoundColumn)
End With
Application.ScreenUpdating = False
On Error Resume Next
Set objChartObj = m_wksSrc.ChartObjects(strChartName)
With objChartObj
sngChartHght = .Height
sngChartWdth = .Width
.Height = Me.imgChart.Height
.Width = Me.imgChart.Width
End With
strFileName = m_strPath & strChartName & ".gif"
If ChartToGif(objChartObj.Chart, strFileName) Then
Me.imgChart.Picture = LoadPicture(strFileName)
Else
Me.imgChart.Picture = LoadPicture("")
End If
Kill strFileName
With objChartObj
.Height = sngChartHght
.Width = sngChartWdth
End With
Set objChartObj = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Private Sub cmdClose_Click()
Me.Hide
End Sub
Private Function ChartToGif(objChart As Chart, _
sFileName As String) As Boolean
On Error GoTo err_ChartToGif
objChart.Export Filename:=sFileName, FilterName:="gif"
ChartToGif = True
Exit Function
err_ChartToGif:
End Function
|
|
|
Code im Codebereich des Moduls |
|
|
Option Explicit
Private Const mc_AppTitle As String = _
"VB-fun-Demo - Eingebettete Diagramme in UserForm anzeigen"
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Public Sub ShowChartsInUserForm()
Dim wks As Worksheet
Dim blnFound As Boolean
If GetVisibleWkbWindows > 0 Then
For Each wks In ActiveWorkbook.Worksheets
If wks.ChartObjects.Count > 0 Then
blnFound = True
Exit For
End If
Next
Else
MsgBox "Keine Arbeitsmappe aktiv!", _
vbOKOnly + vbInformation, mc_AppTitle
End If
If blnFound = True Then
Dim objForm As Object
Set objForm = New frmChartImage
With objForm
.gTitle = mc_AppTitle
.gTempPath = GetTempDir
Set .gWorkbook = ActiveWorkbook
.Init
.Show
End With
Unload objForm
Set objForm = Nothing
Else
MsgBox "In der aktiven Arbeitsmappe sind keine " & _
"eingebetteten Diagramme vorhanden!", _
vbOKOnly + vbInformation, mc_AppTitle
End If
End Sub
Private Function GetVisibleWkbWindows() As Long
Dim objWindow As Window
Dim nWindowsCnt As Long
For Each objWindow In Application.Windows
If objWindow.Visible = True Then
nWindowsCnt = nWindowsCnt + 1
Exit For
End If
Next
GetVisibleWkbWindows = nWindowsCnt
End Function
Private Function GetTempDir() As String
Dim strBuffer As String
Dim nRetVal As Long
Dim strPath As String
strBuffer = Space(255)
nRetVal = GetTempPath(255, strBuffer)
If nRetVal > 0 Then
strPath = Left$(strBuffer, nRetVal)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
GetTempDir = strPath
End Function
|
|
|
|
|
Windows-Version |
95 |
 |
|
98/SE |
 |
|
ME |
 |
|
NT |
 |
|
2000 |
 |
|
XP |
 |
|
Vista |
 |
|
Win
7 |
 |
|
|
Excel-Version |
95 |
 |
|
97 |
 |
|
2000 |
 |
|
2002
(XP) |
 |
|
2003 |
 |
|
2007 |
 |
|
2010 |
 |
|
|
|
Download (30,7
kB)
|
Downloads bisher: [ 3777 ]
|
|
|