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
 
Weitere Links zum Thema
Diagramm-Daten auslesen
Diagramme erstellen

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: [ 3807 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 26. Juni 2011