Bilder

Hallo liebe Excelprofis,
ich könnte bei einem Problem was ich habe eure Hilfe gebrauchen.
Ich habe in einem Tabellenblatt "Erde" ist die Erde abgebildet. Diese besteht aus ca. 200 Ländern, welche je in einem Shape dargestellt ist. Der Name des Shapes entspricht dem Namen des Landes.
In einem 2ten Tabellenblatt "Bild" zeigt ein Shape auf den Bildschirmausschnitt auf Tabelle"Erde"
Ich würde nun gerne ein Makro starten, welches folgendes macht:
Anzahl der Shapes zählen
Schleife mit Anzahl
alle Bilder ausblenden bis auf Shape1
Das Bild im Tabellenblatt "Bild" in eine Bilddateil (jpg) speichern mit dem Namen des Shapes, welches nicht ausgeblednet wurde.
Alle Shapes wieder einblenden
2te Runde der Schleife
Alle Bilder bis auf Shape 2 ausblenden
usw.
Anbei ein kleines Beispiel mit nur ein paar Ländern, damit die Größe nicht überschritten wird...
https://www.herber.de/bbs/user/136056.xlsx
Ziel ist es, dass ich auf dem Laufwerk 200 Bilder habe. wenn ich den Hintergrund ausblende und die Bilder übereinander lege, dass ich dann wieder die Erde habe.
Ist das machbar?
Gruss
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bilder

24.03.2020 07:05:18

stef26

AW: VBA

24.03.2020 09:36:00

Fennek

AW: VBA

24.03.2020 11:30:26

stef26

AW: Weltkarte

24.03.2020 12:42:47

Fennek

AW: Weltkarte

24.03.2020 13:42:50

stef26

AW: Versuch

24.03.2020 16:10:15

Fennek

AW: Weltkarte

24.03.2020 16:46:59

Rolf

AW: Weltkarte

24.03.2020 16:54:49

Rolf

DANKE

24.03.2020 17:41:38

stef26

'speichert Shapes unter ihrem Namen als jpg Sub Shape_save() Dim WS As Worksheet: Set WS = ActiveSheet Dim Cht As Chart Pfad = "c:\users\xxxx\desktop\" ' >> With WS For i = 1 To .Shapes.Count .Shapes.AddChart.Select Set Cht = ActiveChart .Shapes(i).Copy expo = Pfad & .Shapes(i).Name & ".jpg" With Cht Cht.Parent.Width = WS.Shapes(i).Width Cht.Parent.Height = WS.Shapes(i).Height .Paste .Export expo, "jpg" .Parent.Delete End With Next i End With End Sub

Sub Ausblenden() Dim WS As Worksheet: Set WS = ActiveSheet 'im Blatt Chart i = 1 With WS expo = "c:\users\office\desktop\" Debug.Print .Shapes(i).Name, .Shapes(1).Fill.ForeColor '.Shapes(1).Visible = msoTrue 'msoFalse NICHT VERWENDEN .Shapes(i).Fill.Visible = msoTrue 'msoFalse .Shapes(i).Fill.ForeColor.ObjectThemeColor = msoThemeColorText1 .Export expo & .Shapes(i).Name & ".jpg", "jpg" End With End Sub

Hallo Stefan
ich hab mir auch mal was überlegt:
die Sub_Ein_Ausblenden erledigt das Anzeigen der einzelnen Länder und ruft dann
die Sub_Bild_Exportieren zum Speichern eines Zellbereichs auf.
Den Zellbereich musst Du im Code entsprechend deiner gesamten Weltkarte anpassen.
Gruß Rolf

Sub Ein_Ausblenden()
Dim shp As Shape
Dim i As Integer
Dim StrName As String
With Worksheets("Erde")
For Each shp In .Shapes
shp.Visible = False
Next
End With
For i = 1 To Worksheets("Erde").Shapes.Count
StrName = Worksheets("Erde").Shapes(i).Name
With ActiveSheet
.Shapes(i).Visible = True
If i > 1 Then .Shapes(i - 1).Visible = False
End With
Call Bild_exportieren(StrName)
Next
With Worksheets("Erde")
For Each shp In .Shapes
shp.Visible = True
Next
End With
End Sub

Sub Bild_exportieren(BildName)
Dim Zellbereich As Range
Dim Bild As Picture
Dim Diagramm As ChartObject
Set Zellbereich = Range("A1:M30")  'anpassen auf Größe der Weltkarte!!
Application.ScreenUpdating = False
Zellbereich.Copy
Worksheets.Add
Set Bild = ActiveSheet.Pictures.Paste(Link:=True)
Bild.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ActiveSheet.ChartObjects.Add(0, 0, Bild.Width, Bild.Height).Chart
.ChartArea.Select
.Paste
'Pfad anpassen!!
.Export Filename:=ActiveWorkbook.Path & "\Bilder\" & BildName & ".jpg", FilterName:="jpg"
.Parent.Delete
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Set Diagramm = Nothing
Set Bild = Nothing
Set Zellbereich = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread