Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1308to1312
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bilder kopieren...; (FCS) Hallo Franz,

Bilder kopieren...; (FCS) Hallo Franz,
28.04.2013 14:10:00
Lemmi
Hallo Franz,
...Fortzetzung zum PP- Übertrag!!
in der desselben Reihenfolge wie Dein Makro die Zeilen ausliest und PP- überträgt, habe ich nun mir ein Bildverzeichnis erstellt.
Nun möchte ich die Bilder aus diesem Verzeichnis auslesen und passend Folie für Folie ablegen.
Annahme : Die Bilder sind in der selben Reihenfolge wie die Excel- Zeilen…..also die ausgelesenen Zeilen. Dies setze ich ersteinmal vorraus!
Eine Abfrage ob das Bild zum Text passt ist sicherlich äußert kompliziert!
Dazu müsste ich sicherlich noch einige Randbedingungen schaffen/ aufstellen. Dies ist erst einmal nicht notwendig!
Die Bilder liegen in einem Verzeichnis.
Das Verzeichnis habe ich im Arbeitsblatt: Bildverzeichnis; Zelle A1 hinterlegt.
Die Bilder sollen von oben 2 cm von links 2,5 cm abgesetzt werden.
Die Bilder sollen immer die gleiche Höhe haben. ( z. B. 10 cm).
Die Bilder haben eine proportional breite, maximal aber 20cm.
Ich bin einefach von Deinem letzten Makro begeistert, und bin schon neugierig ob meine fehlerträchtige Arbeit entlich ein Ende nimmt!
Ich freue mich schon!
Gruß
Lemmi

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Diashow ohne PowerPoint
28.04.2013 22:12:29
Franz
Hallo Lemmi,
mir konnte FCS Franz auch helfen. Aus einem Tipp über Arrays konnte ich folgende DIASHOW ohne PP (für meine Zwecke) basteln.Viele Wünsche von dir sind darin bereits realisiert, was noch fehlt kannst du ja ergänzen bzw. anpassen, vielleicht auch das Resultat dann hochladen.
https://www.herber.de/bbs/user/85105.xls
Man sieht sich (virtuell)!
Franz D.

AW: Diashow ohne PowerPoint
28.04.2013 22:36:04
Lemmi
Hallo Franz D.,
auch eine intressannte Lösung!Vielen Dank! ...leider bin ich in VBA nicht frim genug um etwas umzustricken!
Trotzdem vielen Dank!
Gruß
Lemmi

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
29.04.2013 07:05:53
fcs
Hallo Lemmi,
ich hab das Makro ergänzt, so dass zusätzlich zum Zellbereich in Excel auch ein Bild aus einer Datei in der Powerpointfolie eingefügt wird.
Ich bin mir aber nicht sicher, ob die Dir-Funktion die Dateinamen der Bilder immer in der von dir gewünschten Reihenfolge ausliest.
https://www.herber.de/bbs/user/85107.txt
Einfacher wäre es,wenn du die Namen der Bilddateien zu den Einträgen im Excelblatt in einer weiteren Spalte des Blattes einfügen/berechnen würdest.
Es ist auch kein so großer Aufwand, den Namen der Bilddatei festzulegen auf Basis von Kriterien (Inhalten der Zellen in der jeweilgen Zeile). Es muss dabei natürlich eine eindeutige Zuordnung möglich sein.
Gruß
Franz

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
29.04.2013 08:45:22
Lemmi
Hallo Franz,
ja, ich will nicht sagen das ich dies schon vorbereitet habe, aber ich fange einfach einmal an.
Meine Bilder in den Verzeichnissen haben folgende Merkmale:
Die Bilder haben alle eine eindeutige Nr.
Sie beginnen immer mit einer zweistelligen Zahl, einem Unterstrich gefolgt von einer dreistelligen Zahl.z. B. 01_000 bis 99_999. Danach folgt der beschriebene Text.
Beispiele eines Bildnamens:
01_004 Haus am See
05_002 Der Nachbar und sein Hund
10_005 Alle Kinder zuhause
Die Tabelle die ich zuletzt aufgeführt habe ist im gleichen „Stiel“ aufgebaut.
Dazu habe ich nochmal die folgende Tabelle beispielhaft angepasst.
https://www.herber.de/bbs/user/85111.xlsx
..jetzt kommt das „aber“
Aus organisatorischen Gründen musste ich die Namens- ID / Information trennen .
-Spalte ab A6 enthält die ersten zwei Zahlen…………… z. B.01
-Der Unterstich ist nicht ausgewiesen………………………. _
-Spalte ab B6 enthält den „dritten Teil“…………….….…z. B. 002
-Spalte ab C6 enthält den Bildnahmen also ……………..Haus am See
-Spalte D6-P…. enthält einen weiteren Bild umschreibenden Text (Eigenschaften)
Q4- Z4 enthält den Verteiler. Wie schon zuvor.
Die Spaltenanzahl hat sich damit nicht geändert.
Der Verzeichnis- Ordner für Bilder liegt im Arbeitsblatt: Bildverzeichnis (A1)
…oder sollte dies anders gelöst werden?
Damit müssten alle Voraussetzungen vorhanden sein…oder fehlt noch etwas?
Gruß
Lemmi

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
29.04.2013 16:03:38
fcs
Hallo Lemmi,
hier die angepasste Variante, die den Dateinamen der Bilder aus den Zellinhalten ermittelt.
Damit das Makro nicht in einen Fehler läuft, wenn eines der Bilder nicht vorhanden ist, habe ich noch etliche Prüfungen eingebaut inkl. einer entsprechenden Meldung.
Gruß
Franz
'Erstellt unter MS Office 2010 professional - Excel 2010, PowerPoint 2010
Option Explicit
Sub ZellbereichePlusBild_Nach_PowerPoint()
'Kopiert Zellbereiche gemäß Kriterien aus dem aktiven Tabellenblatt in eine PowerPoint-Prä _
sentation
Dim PP As Object 'PowerPoint.Application
Dim PP_Datei As Object 'PowerPoint.Presentation
Dim PP_Folie As Object 'PowerPoint.Slide
Dim PP_Shape As Object 'PowerPoint.Shape
Dim a As Double
Dim bool_Erste As Boolean
Dim wks As Worksheet, Spalte As Long, Zeile As Long
Dim strPathPicture As String
Dim strDatei_Soll As String, strDatei_Ist As String, intCount As Integer, strMsg As String
Set PP = CreateObject("Powerpoint.Application")
'PP-Datei in die die Zellbereich in jeweils eine Folie kopiert werden sollen
Const strPP_Datei As String = "C:\Users\Public\Test\Meine Testpräsentation.pptx" 'anpassen!
strPathPicture = Worksheets("Bildverzeichnis").Range("A1").Value
If Right(strPathPicture, 1) = "\" Then
strPathPicture = Left(strPathPicture, Len(strPathPicture) - 1)
End If
With PP
.Visible = True
Set PP_Datei = .Presentations.Open( _
Filename:=strPP_Datei, _
ReadOnly:=True)
End With
bool_Erste = True
Set wks = ActiveSheet
With wks
For Spalte = .Range("Q4").Column To .Range("Z4").Column
If .Cells(4, Spalte).Value = 1 Then
For Zeile = 6 To .Cells(.Rows.Count, Spalte).End(xlUp).Row
If LCase(.Cells(Zeile, Spalte).Value) = "x" Then
'Letzte Folie setzen
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
If bool_Erste = True Then
'bei erster grafik letzte Folie nicht duplizieren
bool_Erste = False
Else
PP_Folie.Duplicate
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
'Letzte beiden Grafiken in letzter Folie löschen
With PP_Folie
.Shapes(.Shapes.Count).Delete
If intCount = 2 Then .Shapes(.Shapes.Count).Delete
End With
End If
'Zellbereich in Excel kopieren
.Range(.Cells(Zeile, 1), .Cells(Zeile, 16)).Copy
'kopierten Bereich in PP einfügen
PP_Folie.Shapes.PasteSpecial DataType:=3 'ppPasteMetafilePicture
'            PP_Folie.Shapes.PasteSpecial DataType:=2 'ppPasteEnhancedMetafile
'            PP_Folie.Shapes.PasteSpecial DataType:=10, Link:=0 'ppPasteOLEObject ohne Link
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Grafik positionieren
With PP_Shape
a = 72 / 2.54 'Umrechnungsfaktor cm in Points
.Left = 2.5 * a '2,5 cm vom linken Rand
.Top = (19.05 - 1) * a - .Height  '1 cm vo unteren Rand _
19.05 cm = Höhe der Folie, ggf. anpassen
.Line.Visible = msoCTrue
End With
Application.CutCopyMode = False
intCount = 1 '1 Grafikobjekt (Shape) eingefügt
'Name des Bildes einlesen
strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".*"
'            strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".jpg")
'Prüfen, ob Datei existiert
strDatei_Ist = Dir(Pathname:=strPathPicture & "\" & strDatei_Soll)
If strDatei_Ist  "" Then
'Bild einfügen
PP_Folie.Shapes.AddPicture Filename:=strPathPicture & "\" & strDatei_Ist, _
linktofile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=2.5 * a, Top:=2 * a
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Bild Größe anpassen
With PP_Shape
.LockAspectRatio = msoTrue
.Height = 10 * a '10 cm hoch
End With
intCount = intCount + 1 'weiteres Grafikobjekt (Shape) eingefügt
Else
strMsg = strMsg & vbLf & "Zeile " & Zeile & ": " & strPathPicture & "\" _
& strDatei_Soll
End If
End If
Next Zeile
End If
Next Spalte
If strMsg  "" Then
PP.WindowState = 2 'ppWindowMinimized
Application.WindowState = xlMinimized
Application.WindowState = xlMaximized
MsgBox "Folgende Bilder wurden nicht gefunden!" & strMsg
Else
PP.WindowState = 3 'ppWindowMaximized
End If
End With 'wks
Set PP = Nothing: Set PP_Datei = Nothing: Set PP_Folie = Nothing
Set PP_Shape = Nothing: Set wks = Nothing
End Sub

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
01.05.2013 14:24:08
Lemmi
Wow Franz,
einfach klasse!
Nach einigen Tests habe ich dennoch eine Bitte,
strPathPicture = Worksheets("Bildverzeichnis").Range("A1").Value
If Right(strPathPicture, 1) = "\" Then
strPathPicture = Left(strPathPicture, Len(strPathPicture) - 1)
...liest ja das auszulesende Bild Verzeichnis aus.
Leider habe ich nicht bedacht, dass sich der Ordnername immer leicht verändert.
Dies hängt mit der Auswahl in Q4-Z4 zusammen.
Kannst Du nocheinmal Hand anlegen?
Wäre es möglich, das das Auswahlverzeichnis in A1 "nur zur Vorauswahl genutzt werden kann?... und die eigendliche Auswahl durch ein Dialogfester gezuführt wird.
D.h. z. B.
C:\Users\Public\Test\Zusammenfassung Bilder 01 gfds
C:\Users\Public\Test\Zusammenfassung Bilder 02 ddffer
C:\Users\Public\Test\Zusammenfassung Bilder 03mmmbbbgg
Zusammenfassung Bilder 01-03.... sind die Ordner in denen die inviduellen Bildsammlungen enthalten sind
.....
C:\Users\Public\Test\.... soll in A1(Arbeitsbaltt: Bildverzeichnisse)ausgelesen werden.
Die nachgeschaltete Auswahl (Dialogfeld) lässt das selektieren der letzten Ordnerebene zu.
Vielen Dank im Vorraus!
Gruß
Lemmi

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
01.05.2013 15:16:57
Lemmi
Hallo Fanz,
ich möchte Deine wirklich tolle Hilfe nicht übergebühr beanspruchen.
Es ist ja noch eine Verbesserung auf der Srecke geblieben.
Wenn die Excel Zelle kopiert werden
'Zellbereich in Excel kopieren
.Range(.Cells(Zeile, 1), .Cells(Zeile, 16)).Copy
dann kopiert das Makro 16 Zellen in Folge (A-P) diese kommen aber nicht alle in PP an? Warum?
Liegt es daran das alles 1:1 kopiert wird und wenn die Seite nicht mehr groß genug ist wird das Shape beschnitten?!!
Es ist glaubig am besten wenn alle Inhalte herüber kopiert werden, ist das Bild zu breit so kann auch gestaucht werden.
Die breite soll aber auf 20 cm begrent werden. (also 1:1 übertragung mit ggf. Stauchgefahr)
Kannst Du das vieleicht auch noch einpflegen?
Vielen vielen Dank im Vorraus!....na hoffendlich klappt das !
Gruß
Lemmi

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
02.05.2013 12:20:56
fcs
Hallo Lemmi,
ich hab das Makro nochmals angepasst.
Verzeichnisauswahl erfolgt wenn eine 1 im Bereich Q4:Z4 gefunden wird. Danach wird dann die PP-Vorlage geöffnet usw.
Der zu kopierende Bereich A bis P wird jetzt nur noch bis zur letzten ausgefüllten Spalte kopiert. Ist das Bild breiter als 20 cm, dann wird es auf Breite 20 cm geändert.
Gruß
Franz
'Erstellt unter MS Office 2010 professional - Excel 2010, PowerPoint 2010
Option Explicit
Sub ZellbereichePlusBild_Nach_PowerPoint()
'Kopiert Zellbereiche gemäß Kriterien aus dem aktiven Tabellenblatt in eine _
PowerPoint-Präsentation
Dim PP As Object 'PowerPoint.Application
Dim PP_Datei As Object 'PowerPoint.Presentation
Dim PP_Folie As Object 'PowerPoint.Slide
Dim PP_Shape As Object 'PowerPoint.Shape
Dim a As Double
Dim bool_Erste As Boolean
Dim wks As Worksheet, Spalte As Long, Zeile As Long, SpaBereich As Long
Dim strPathPicture As Variant, strSpalte As String
Dim strDatei_Soll As String, strDatei_Ist As String, intCount As Integer, strMsg As String
'PP-Datei in die die Zellbereich in jeweils eine Folie kopiert werden sollen
Const strPP_Datei As String = "C:\Users\Public\Test\Meine Testpräsentation.pptx" 'anpassen!
'Startverzeichnis für Auswahl Bilder-Verzeichnis
strPathPicture = Worksheets("Bildverzeichnis").Range("A1").Value
If Right(strPathPicture, 1) = "\" Then
strPathPicture = Left(strPathPicture, Len(strPathPicture) - 1)
End If
Set wks = ActiveSheet
With wks
For Spalte = .Range("Q4").Column To .Range("Z4").Column
If .Cells(4, Spalte).Value = 1 Then
'Verzeichnisauswahl
strSpalte = .Columns(Spalte).Address(rowabsolute:=False, columnabsolute:=False, _
ReferenceStyle:=xlA1)
strSpalte = Mid(strSpalte, InStr(1, strSpalte, ":") + 1)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis für Bilder zu Verteiler in Spalte """ & strSpalte _
& """ auswählen"
.InitialFileName = strPathPicture & "\*.*"
If .Show = -1 Then
strPathPicture = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
'Powerpoint-Vorlage öffnen
Set PP = CreateObject("Powerpoint.Application")
With PP
.Visible = True
Set PP_Datei = .Presentations.Open( _
Filename:=strPP_Datei, _
ReadOnly:=True)
End With
bool_Erste = True
For Zeile = 6 To .Cells(.Rows.Count, Spalte).End(xlUp).Row
If LCase(.Cells(Zeile, Spalte).Value) = "x" Then
'Letzte Folie setzen
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
If bool_Erste = True Then
'bei erster grafik letzte Folie nicht duplizieren
bool_Erste = False
Else
PP_Folie.Duplicate
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
'Letzte beiden Grafiken in letzter Folie löschen
With PP_Folie
.Shapes(.Shapes.Count).Delete
If intCount = 2 Then .Shapes(.Shapes.Count).Delete
End With
End If
'letzte gefüllte Zelle im zu kopierenden Bereich ermitteln
For SpaBereich = 16 To 1 Step -1
If .Cells(Zeile, SpaBereich)  "" Then Exit For
Next SpaBereich
If SpaBereich  20 * a Then .Width = 20 * a 'Breite 20 cm
.Top = (19.05 - 1) * a - .Height  '1 cm vo unteren Rand _
19.05 cm = Höhe der Folie, ggf. anpassen
.Line.Visible = msoCTrue
End With
Application.CutCopyMode = False
intCount = 1 '1 Grafikobjekt (Shape) eingefügt
'Name des Bildes einlesen
strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".*"
'            strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".jpg")
'Prüfen, ob Datei existiert
strDatei_Ist = Dir(Pathname:=strPathPicture & "\" & strDatei_Soll)
If strDatei_Ist  "" Then
'Bild einfügen
PP_Folie.Shapes.AddPicture Filename:=strPathPicture & "\" & strDatei_Ist, _
linktofile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=2.5 * a, Top:=2 * a
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Bild Größe anpassen
With PP_Shape
.LockAspectRatio = msoTrue
.Height = 10 * a '10 cm hoch
End With
intCount = intCount + 1 'weiteres Grafikobjekt (Shape) eingefügt
Else
strMsg = strMsg & vbLf & "Zeile " & Zeile & ": " & strPathPicture & "\" _
& strDatei_Soll
End If
End If
Next Zeile
Exit For
End If
Next Spalte
If strMsg  "" Then
PP.WindowState = 2 'ppWindowMinimized
Application.WindowState = xlMinimized
Application.WindowState = xlMaximized
MsgBox "Folgende Bilder wurden nicht gefunden!" & strMsg
Else
PP.WindowState = 3 'ppWindowMaximized
End If
End With 'wks
Beenden:
Set PP = Nothing: Set PP_Datei = Nothing: Set PP_Folie = Nothing
Set PP_Shape = Nothing: Set wks = Nothing
End Sub

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
02.05.2013 22:45:20
Lemmi
Hallo Franz,
der erste Teil, das Auswählen der Verzeichnisse, klappt hervorragend. Danke danke Danke!
Ich weis nicht ob ich etwas falsch mache. Es wird nach wie vor die Kopie der Zeile nicht vollständig übertragen.
Soweit ich das beurteilen kann kopiert er alles in Excel (Zeile A bis P)
Das Makro setzt aber nicht mehr alles ab.
Wenn ich die Spalten in Ihrer Breite verkleinere so wird immer mehr übertragen (Mehr zellen).
Die Übertragungmenge bezüglich Zellen scheint sich zu erhöhen, je kleiner die Spaltenbreite von A- P ist.
Ich habe noch einmal zusammen gezählt meine Spaltenbreite alle Zellen beträgt in der Orginaldatei maximal von A- P 253.
Schaust Du noch mal?
Gruß
Lemmi

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
03.05.2013 12:22:46
fcs
Hallo Lemmi,
in deiner Datei mit den Testdaten trat dieses Phänomen nicht auf, erst nach Vergrößern von Spaltenbreiten.
Es gibt also scheinbar eine max. Breite eines Zellbereichs, die nach dem Kopieren in PP als Grafik eingefügt werden kann.
Ich hab das jetzt so gelöst, dass der relevante Zellbereich in Excel kopiert und als Grafik eingefügt wird. Ggf. wird die Breite auf 20 cm reduziert. Die Größe der Grafik wird dabei auf bis zu 40 % reduziert. Das funktioniert merkwürdigerweise. Anschließend wird die Grafik von Excel nach PP kopiert und in Excel wieder gelöscht.
Gruß
Franz
'Erstellt unter MS Office 2010 professional - Excel 2010, PowerPoint 2010
Option Explicit
Sub ZellbereichePlusBild_Nach_PowerPoint()
'Kopiert Zellbereiche gemäß Kriterien aus dem aktiven Tabellenblatt in _
eine PowerPoint-Präsentation            Stand: 2013-05-03
Dim PP As Object 'PowerPoint.Application
Dim PP_Datei As Object 'PowerPoint.Presentation
Dim PP_Folie As Object 'PowerPoint.Slide
Dim PP_Shape As Object 'PowerPoint.Shape
Dim a As Double
Dim xl_Shape As Shape
Dim bool_Erste As Boolean
Dim wks As Worksheet, Spalte As Long, Zeile As Long, SpaBereich As Long
Dim strPathPicture As Variant, strSpalte As String
Dim strDatei_Soll As String, strDatei_Ist As String, intCount As Integer, strMsg As String
'PP-Datei in die die Zellbereich in jeweils eine Folie kopiert werden sollen
Const strPP_Datei As String = "C:\Users\Public\Test\Meine Testpräsentation.pptx" 'anpassen!
'Startverzeichnis für Auswahl Bilder-Verzeichnis
strPathPicture = Worksheets("Bildverzeichnis").Range("A1").Value
If Right(strPathPicture, 1) = "\" Then
strPathPicture = Left(strPathPicture, Len(strPathPicture) - 1)
End If
Set wks = ActiveSheet
With wks
For Spalte = .Range("Q4").Column To .Range("Z4").Column
If .Cells(4, Spalte).Value = 1 Then
'Verzeichnisauswahl
strSpalte = .Columns(Spalte).Address(rowabsolute:=False, columnabsolute:=False, _
ReferenceStyle:=xlA1)
strSpalte = Mid(strSpalte, InStr(1, strSpalte, ":") + 1)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis für Bilder zu Verteiler in Spalte """ & strSpalte _
& """ auswählen"
.InitialFileName = strPathPicture & "\*.*"
If .Show = -1 Then
strPathPicture = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
'Powerpoint-Vorlage öffnen
Set PP = CreateObject("Powerpoint.Application")
With PP
.Visible = True
Set PP_Datei = .Presentations.Open( _
Filename:=strPP_Datei, _
ReadOnly:=True)
End With
bool_Erste = True
For Zeile = 6 To .Cells(.Rows.Count, Spalte).End(xlUp).Row
If LCase(.Cells(Zeile, Spalte).Value) = "x" Then
'Letzte Folie setzen
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
If bool_Erste = True Then
'bei erster grafik letzte Folie nicht duplizieren
bool_Erste = False
Else
PP_Folie.Duplicate
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
'Letzte beiden Grafiken in letzter Folie löschen
With PP_Folie
.Shapes(.Shapes.Count).Delete
If intCount = 2 Then .Shapes(.Shapes.Count).Delete
End With
End If
'letzte gefüllte Zelle im zu kopierenden Bereich ermitteln
For SpaBereich = 16 To 1 Step -1
If .Cells(Zeile, SpaBereich)  "" Then Exit For
Next SpaBereich
If SpaBereich  Application.CentimetersToPoints(20) Then
.Width = Application.CentimetersToPoints(20)
End If
.Copy
End With
'kopierten Bereich in PP einfügen
PP_Folie.Shapes.PasteSpecial DataType:=3 'ppPasteMetafilePicture
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Grafik positionieren
With PP_Shape
a = 72 / 2.54 'Umrechnungsfaktor cm in Points
.Left = 2.5 * a '2,5 cm vom linken Rand
.Top = (19.05 - 1) * a - .Height  '1 cm vo unteren Rand _
19.05 cm = Höhe der Folie, ggf. anpassen
.Line.Visible = msoCTrue
End With
Application.CutCopyMode = False
xl_Shape.Delete
intCount = 1 '1 Grafikobjekt (Shape) eingefügt
'Name des Bildes einlesen
strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".*"
'            strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".jpg")
'Prüfen, ob Datei existiert
strDatei_Ist = Dir(Pathname:=strPathPicture & "\" & strDatei_Soll)
If strDatei_Ist  "" Then
'Bild einfügen
PP_Folie.Shapes.AddPicture Filename:=strPathPicture & "\" & strDatei_Ist, _
linktofile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=2.5 * a, Top:=2 * a
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Bild Größe anpassen
With PP_Shape
.LockAspectRatio = msoTrue
.Height = 10 * a '10 cm hoch
End With
intCount = intCount + 1 'weiteres Grafikobjekt (Shape) eingefügt
Else
strMsg = strMsg & vbLf & "Zeile " & Zeile & ": " & strPathPicture & "\" _
& strDatei_Soll
End If
End If
Next Zeile
Exit For
End If
Next Spalte
If strMsg  "" Then
PP.WindowState = 2 'ppWindowMinimized
Application.WindowState = xlMinimized
Application.WindowState = xlMaximized
MsgBox "Folgende Bilder wurden nicht gefunden!" & strMsg
Else
PP.WindowState = 3 'ppWindowMaximized
End If
End With 'wks
Beenden:
Set PP = Nothing: Set PP_Datei = Nothing: Set PP_Folie = Nothing
Set PP_Shape = Nothing: Set wks = Nothing: Set xl_Shape = Nothing
End Sub

Anzeige
AW: Zellbereich + Bilddatei nach Powerpoint
03.05.2013 23:08:19
Lemmi
Hallo Franz,
klappt immer noch nicht!
Das Programm hängt bei .copy
'Zellbereich als Grafik in aktives Blatt einfügen und ggf. Breite anpassen
.....
End If
.Copy
End With
...mit der Meldung Laufzeitfehler 1004
Ich kann an der Ecxel Tabelle auch keine weiteren Fehler finden.
gruß
Lemmi

AW: Zellbereich + Bilddatei nach Powerpoint
04.05.2013 07:24:41
fcs
Hallo Lemmi,
da bin ich jetzt mit meinem Latein am Ende.
Bei mir funktioniert das Makro auf zwei Rechnern.
MS Office Version: Professional Plus 2010, 14.0.6129.5000 (32 Bit)
MS Excel Version: 2010 (14.0.6126.5003) SP1
Betriebssystem: 1 mal Windows XP, 1 mal Windows Vista
Ich hab das Makro auch auf verschiedene Arten gestartet - Formular-Schaltfläche, Active-X-Schaltfläche, Makro-Dialog, direkt im VBA-Editor. Alle funktionieren - am Ende des Makros wurde nicht immer die PP-Präsentation, warum auch immer.
Ich weiss nicht, ob hier kleine Unterschiede zwischen den Office-Versionen relevant sein können.
Gruß
Franz

AW: Zellbereich + Bilddatei nach Powerpoint
05.05.2013 07:42:30
Lemmi
Hallo Franz,
ja das Makro funktioniert! Super!
Jedoch scheint es ausschließlich in meiner Originaldatei Probleme zu geben!
Nach einigen Test's (mit Excel 2007; Windows 7) habe ich folgende Fehler bei mir festgestellt.
Nehme ich meine "Orginaldatei" dann gibt es eine Fehlermeldung...warum auch immer. Hier fehlt mir nach wie vor die Ursache.
Wenn ich nun eine neue unbescholtenen Datei + Dein Makro nehme ist alles gut. Das Makro funktioniert.(Hier habe ich die Tabelle vereinfacht neu aufgezogen)
Übertrage bzw. verschieb ich dieses Arbeitsblatt in die Originaldatei funktioniert mit dessen Arbeitsblatt auch alles.Kopiere ich einen Tabellenanteil in das orginal Arbeitsblatt gibt es immer noch die Fehlermeldung.
...also müsste es mit dem meinem Arbeitsblatt zusammenhängen... Hier werde ich mich noch einmal auf die Suche machen und mich noch einmal melden. Ich werde einen neuen Beitrag öffnen! ...voraussichtlich am 13.05.und Dich "anschreiben"
Ein "Nebenproblem" welches ich festgestellt habe, ist wahrscheinlich keines!
Wenn ich das richtig nachvollzogen habe, wird durch Dein Makro die Anzahl der zu übertragenden Zellen begrenzt. Es werden nur so viel Zellen übertragen wie es auch Inhalte gibt.
D.h. wenn Spalte C den letzten Eintrag hat, dann wird auch nur bis C übertragen Der Übertrag ist kürzer als wenn ich bis Zelle P einen Eintrag durchgeführt habe. Dies hat mich lange Zeit annehmen lassen es fehlt etwas.
Ich würde gerne immer alle Zellen übertragen. (A-P)... Mit einer Ausnahme. Werden ganze Spalten ausgeblendet, so werden diese auch nicht übertragen ...aber das macht das Makro ja.
Gruß
Lemmi

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige