Organigramm als Gif speichern

Hallo,
habt Ihr eine Idee bei folgenden Bedingungen:
In einer Excel-Tabelle habe ich eine PPT-Folie mit einem Hintergrundbild auf der ein Organigramm eingebettet ist.
Zu Fuß erhalte ich genau das Ergebnis welches ich brauche:
1. Anklicken Objekt und Folie-Objekt Bearbeiten auswählen
2. Anklicken Organigramm und Als Grafik speichern auswählen
3. Speichern unter einem gewünschten Namen (wobei der Dateityp EWM für mich am besten ist). Kann zur Not aber auch Gif sein.

In der Userform lade ich dann das Bild mit Load Picture, welches 100% dem gewünschten Ergebnis entspricht.
Zur Zeit löse ich das ganze mit Vorschlägen aus dem Forum (Snapshot). Leider kann ich aber dann nur das gesamte Objekt als Gif speichern.
Deshalb meine Frage und große Bitte, könnt Ihr mir den zu Fuß beschriebenen Weg als VBA-Code darstellen, vielleicht kann man ja auch Snapshot anpassen.
Danke für jede Hilfe im voraus.
Gruß
Wolfgang

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Re: Organigramm als Gif speichern

08.05.2003 15:15:29

Michael Schefflewr

Danke, brauche aber VBA

08.05.2003 15:24:21

Wolfgang

Re: Danke, brauche aber VBA

08.05.2003 15:32:35

Michael Scheffler

Danke, aber noch offen

08.05.2003 15:44:22

Wolfgang

Re: Danke, aber noch offen

08.05.2003 17:59:13

Michael Scheffler

API ?

08.05.2003 21:38:06

Wolfgang

Re: API ?

09.05.2003 13:57:06

Michael Scheffler

Korrekt

09.05.2003 15:24:52

Wolfgang

Hallo Micha,
genau so. Wobei mir klar ist, dass ich um nach Punkt 2 zu kommen einen Umweg legen muß.
Dieser lautet im Moment:

Dim container As Chart
Dim containerbok As Workbook
Dim AK As String

Private Sub ImageContainer_init()
Workbooks.Add (1)
ActiveSheet.Name = "GIFcontainer"
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="GIFcontainer"
Set containerbok = ActiveWorkbook
Set container = ActiveChart
End Sub

Sub MakeAndSizeChart(ih As Integer, iv As Integer)
Dim Höhe As Single
Dim Breite As Single
AK = Mid(ActiveChart.Name, Len(ActiveSheet.Name) + 1)
Höhe = ih / ActiveChart.ChartArea.Height
ActiveSheet.Shapes(AK).ScaleHeight Höhe, msoFalse, msoScaleFromTopLeft
Breite = iv / ActiveChart.ChartArea.Width
ActiveSheet.Shapes(AK).ScaleWidth Breite, msoFalse, msoScaleFromTopLeft
End Sub

Public Sub GIF_Snapshot()
Dim varReturn As Variant
Dim MySuggest As String
Dim Hi As Integer
Dim Wi As Integer
Dim Suffiks As Long
Dim BildName As String

BildName = "Krankenhaus1"

ImageContainer_init
ThisWorkbook.Activate
ActiveSheet.Shapes("Objekt 1").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Hi = Selection.Height + 2 'adjustment for gridlines
Wi = Selection.Width + 3 'adjustment for gridlines
containerbok.Activate
ActiveSheet.ChartObjects(1).Activate
MakeAndSizeChart ih:=Hi, iv:=Wi
ActiveChart.Paste
ActiveChart.Export Filename:=LCase(BildName) & ".gif", FilterName:="GIF"
ActiveChart.Pictures(1).Delete
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub

Das übertragen "Objekt 1" enthält aber ein eingebettetes Organigramm und nur dieses brauche ich eigentlich.
Handisch steht dann in meiner Userform nämlich nur das Organigramm, ohne Rahmen ect. mit dem original grauen Userformlayout.
Gruß
Wolfgang

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread