UserForm - Diagrams!

Since the Web components by Microsoft are not always installed a diagram can be indicated over detours in a UserForm. With the following code diagrams are indicated in a UserForm. The diagram is in the determined "Temp-Folder" temporarly stored, then in "Frame Picture" of the UserForm loaded and in "Temp-Folder" deleted.


Da die Webkomponenten von Microsoft nicht immer installiert sind kann ein Diagramm auch über Umwege in einer UserForm angezeigt werden. Mit dem folgenden Code werden Diagramme in einer UserForm angezeigt. Das Diagramm wird im ermittelten "TEMP-Ordner" temporär gespeichert, dann in den "Frame Picture" der UserForm geladen und ím "TEMP-Ordner" gelöscht. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007.


' Code in "DieseArbeitsmappe"
Option Explicit
Private Sub Workbook_Open()
Application.OnKey "{F4}", "Module1.UF_Show"
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "{F4}"
End Sub

' Code in "UserForm1"
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Activate()
Dim wksSheet As Worksheet
On Error GoTo Fin
For Each wksSheet In ThisWorkbook.Worksheets
ListBox1.AddItem wksSheet.Name
Next
With Me
.ListBox2.Visible = False
.Label1.Visible = False
.Label3.Visible = False
End With
Application.VBE.MainWindow.Visible = False
Application.Visible = False
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub ListBox1_Click()
Dim sngOldWidth As Single
Dim sngOldHeight As Single
Dim wksSheet As Worksheet
Dim intCount As Integer
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets(ListBox1.Text)
With Me
.ListBox2.Visible = False
.Label3.Visible = False
.Label1.Visible = False
.Label4.Visible = False
.ListBox2.Clear
End With
If wksSheet.ChartObjects.Count > 1 Then
ListBox2.Visible = True
Label3.Visible = True
For intCount = 1 To wksSheet.ChartObjects.Count
ListBox2.AddItem wksSheet.ChartObjects _
(intCount).Chart.ChartTitle.Text
Next
Frame1.Picture = LoadPicture()
Set wksSheet = Nothing
Label1.Visible = True
Exit Sub
Else
With ThisWorkbook.Worksheets(ListBox1.Text).ChartObjects(1)
sngOldWidth = .ShapeRange.Width
sngOldHeight = .ShapeRange.Height
.ShapeRange.Width = Frame1.Width
.ShapeRange.Height = Frame1.Height
.Chart.Export Filename:=GetTempDir & _
"Chart.gif", FilterName:="GIF"
.ShapeRange.Width = sngOldWidth
.ShapeRange.Height = sngOldHeight
End With
End If
With Frame1
.PictureSizeMode = fmPictureSizeModeZoom
.Picture = LoadPicture(GetTempDir & "Chart.gif")
End With
Kill (GetTempDir & "Chart.gif")
Fin:
Set wksSheet = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub ListBox2_Click()
Dim sngOldWidth As Single
Dim sngOldHeight As Single
Dim wksSheet As Worksheet
Dim intCount As Integer
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets(ListBox1.Text)
Label1.Visible = False
With ThisWorkbook.Worksheets(ListBox1.Text). _
ChartObjects(ListBox2.ListIndex + 1)
sngOldWidth = .ShapeRange.Width
sngOldHeight = .ShapeRange.Height
.ShapeRange.Width = Frame1.Width
.ShapeRange.Height = Frame1.Height
.Chart.Export Filename:=GetTempDir & _
"Chart.gif", FilterName:="GIF"
.ShapeRange.Width = sngOldWidth
.ShapeRange.Height = sngOldHeight
End With
With Frame1
.PictureSizeMode = fmPictureSizeModeZoom
.Picture = LoadPicture(GetTempDir & "Chart.gif")
End With
Kill (GetTempDir & "Chart.gif")
Fin:
Set wksSheet = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
MsgBox "Click Button ""ESC""!"
Cancel = True
Else
Application.VBE.MainWindow.Visible = True
Application.Visible = True
End If
End Sub
Public Function GetTempDir() As String
Dim strTMP As String
Dim lngCount As Long
Dim strPath As String
On Error GoTo Fin
strTMP = Space(255)
lngCount = GetTempPath(255, strTMP)
If lngCount > 0 Then
strPath = Left$(strTMP, lngCount)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
GetTempDir = strPath
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Function

' Code in ein "Modul"
Option Explicit
Public Sub UF_Show()
UserForm1.Show
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...