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

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