Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1280to1284
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 in Excel einfügen

Bilder in Excel einfügen
10.10.2012 10:36:58
Ano
Hallo zusammen,
habe ein Problem bei einem alten VBA, bei dem ich mehrere Bilder aus einem Ordner in vordefinierte Felder in einem Excel-Sheet speicher. Ich habe schon herausgefunden, dass unter Office 2010 "ActiveSheet.Picture.Insert" nicht funktioniert, aber noch keine passende Lösung gefunden. Vielleicht könnt ihr mir dabei helfen.
Hier mein Code
Sub BilderEinfuegen()
Dim i As Long
Dim PicBild As Picture
Dim PfadDatei$, PfadBilder$
Dim Objekt As Object
Dim arrBereiche As Variant
arrBereiche = Array("A6,L24", "N6,Y24", "A28,L46", "N28,Y46", "A51,L69", "N51,Y69", "A73,L91" _
_
, "N73,Y91", _
"A96,L114", "N96,Y114", "A118,L136", "N118,Y136", "A141,L159", "N141,Y159", "A163,  _
_
L181", "N163,Y181", _
"A186,L204", "N186,Y204", "A208,L226", "N208,Y226")
PfadDatei = ThisWorkbook.Path
PfadBilder = PfadDatei & "\Bilder\"
Application.ScreenUpdating = False
'Löschen bereits eingefügter Bilder
For Each Objekt In ActiveSheet.Shapes
If Objekt.AlternativeText  "Bilder einfügen" Then
Objekt.Delete
End If
Next
'In die Zellbereiche werden Bilder mit dem dort stehenden Namen eingefügt
For i = 0 To UBound(arrBereiche) Step 1
If Range(arrBereiche(i)).Value > "00" Then
Set PicBild = _
ActiveSheet.Pictures.Insert(PfadBilder & Range(arrBereiche(i)).Value & ".jpg")
With ActiveSheet.Pictures(ActiveSheet.Pictures.Select)
'Ausrichten der Bilder
PicBild.Top = Range(arrBereiche(i)).Top
PicBild.Left = Range(arrBereiche(i)).Left
'Bild quer
If ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Width > _
ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Height Then
PicBild.Width = Range(arrBereiche(i)).Width
PicBild.Top = Range(arrBereiche(i)).Top + _
(Range(arrBereiche(i)).Height - ActiveSheet.Pictures(ActiveSheet. _
Pictures.Count).Height) / 2
'Bild hochkant
Else
PicBild.Height = Range(arrBereiche(i)).Height
PicBild.Left = Range(arrBereiche(i)).Left + _
(Range(arrBereiche(i)).Width - ActiveSheet.Pictures(ActiveSheet. _
Pictures.Count).Width) / 2
End If
End With
Else
'In Zellbereichen mit dem Wert 00 werden keine Bilder eingefügt
End If
Next i
Application.ScreenUpdating = True
Set PicBild = Nothing
End Sub

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bilder in Excel einfügen
10.10.2012 13:07:30
JoWE
Hallo Simon,
hast Du es scho mal mit:
Set myDocument = Worksheets(1)
myDocument.Shapes.AddPicture "Hier Pfad und Filename", True, True, 100, 100, 70, 70
probiert?!

Gruß
Jochen

AW: Bilder in Excel einfügen
10.10.2012 14:13:44
Ano
Hab´s versucht, aber das hilft mir noch nicht weiter. Scheitert vlt. auch an meinen Kenntnissen.
Kann mir das jemand in den Code schreiben?

AW: Bilder in Excel einfügen
10.10.2012 20:58:36
JoWE
Hallo Simon,
hier ein Versuch: https://www.herber.de/bbs/user/82062.xlsm
Habe den Teil, der sich mit Hoch-/Querformat befasst weggelassen.
Wusste auch nicht so richtig wie das Ergebnis aussehen sollte.
Gruß
Jochen

Anzeige
AW: Bilder in Excel einfügen
11.10.2012 13:30:12
Ano
Hallo Jochen,
vielen Dank für deinen Tip.
Ich habe meinen Code nochmal neu aufgebaut und jetzt klappt es auch schon ganz gut.
Jetzt muss ich aber nur noch das Durchsuchen des Ordners auf jpg begrenzen.
Wie mache ich das bei diesem Code?
Sub Pfadbilder()
'Schreibt PfadBilder
Set FSO = CreateObject("Scripting.Filesystemobject")
Set Ordner = FSO.GetFolder(PfadBilder)
For Each datei In Ordner.Files
anzahldatei = anzahldatei + 1
ActiveWorkbook.ActiveSheet.Cells(anzahldatei, 55) = datei
Next
End Sub

AW: Bilder in Excel einfügen
11.10.2012 13:55:38
Ano
Habe es jetzt doch noch geschafft!
Falls jemand mal was ähnliches sucht, das folgende marko macht folgendes:
1.Listet alle Bilder eines Ordners als Pfad auf
2. Fügt die Bilder in vordefinierte Bereiche ein
3. passt die Größe der Bilder der Bereiche an.
Sub insertPIC()
Dim arrPic As Variant
Dim arrBereiche As Variant
Dim PicBild As Picture
arrPic = Array("BC1", "BC2", "BC3", "BC4", "BC5", "BC6", "BC7", "BC8", "BC8", "BC10", "BC11" _
, "BC12", "BC13", "BC14", "BC15", "BC16", "BC17", "BC18", "BC19", "BC20")
arrBereiche = Array("A6:L24", "N6:Y24", "A28:L46", "N28:Y46", "A51:L69", "N51:Y69", "A73: _
L91", "N73:Y91", _
"A96:L114", "N96:Y114", "A118:L136", "N118:Y136", "A141:L159", "N141:Y159", "A163: _
L181", "N163:Y181", _
"A186:L204", "N186:Y204", "A208:L226", "N208:Y226")
PfadDatei = ThisWorkbook.Path
PfadBilder = PfadDatei & "\Bilder\"
'Löschen bereits eingefügter Bilder
For Each Objekt In ActiveSheet.Shapes
If Objekt.AlternativeText  "Bilder einfügen" Then
Objekt.Delete
End If
Next
Range("BC:BC").Delete
'Schreibt PfadBilder
strPath = (PfadBilder & "\" & "*.jpg")
Dim strFile As String
Dim intTMP As Integer
strFile = dir(strPath)
intTMP = 1 'ab Zeile
Do While strFile  ""
Cells(intTMP, 55).Value = PfadBilder & strFile
intTMP = intTMP + 1
strFile = dir()
Loop
'Set FSO = CreateObject("Scripting.Filesystemobject")
'Set Ordner = FSO.GetFolder(PfadBilder)
'For Each datei In Ordner.Files
'anzahldatei = anzahldatei + 1
'ActiveWorkbook.ActiveSheet.Cells(anzahldatei, 55) = datei
'Next
'Stellt Anzahl der Bilder fest
CountPic = Application.WorksheetFunction.CountA(Range("BC:BC"))
Range(arrBereiche(i)).Select
For i = 0 To CountPic - 1
ActiveSheet.Pictures.Insert(Range(arrPic(i)).Value).Select
'Selection.ShapeRange.ScaleWidth 0.25, msoFalse, msoScaleFromTopLeft
'Selection.ShapeRange.ScaleHeight 0.25, msoFalse, msoScaleFromTopLeft
'Ausrichten der Bilder
Selection.ShapeRange.Top = Range(arrBereiche(i)).Top
Selection.ShapeRange.Left = Range(arrBereiche(i)).Left
'Bild quer
If Selection.ShapeRange.Height > Selection.ShapeRange.Width Then
'Selection.ShapeRange.Width = Range(arrBereiche(i)).Width
'Selection.ShapeRange.Top = Range(arrBereiche(i)).Top + _
(Range(arrBereiche(i)).Height - Selection.ShapeRange.Height) /  _
2
'Selection.ShapeRange.ScaleHeight 0.4, msoFalse,  _
msoScaleFromTopLeft
Selection.ShapeRange.Height = Rows("6:24").Height
'Bild hochkant
Else
'Selection.ShapeRange.Height = Range(arrBereiche(i)).Height
'Selection.ShapeRange.Left = Range(arrBereiche(i)).Left + _
(Range(arrBereiche(i)).Width - Selection.ShapeRange.Width) / 2
'Selection.ShapeRange.ScaleWidth 0.3, msoFalse,  _
msoScaleFromTopLeft
Selection.ShapeRange.Width = Columns("A:L").Width
End If
Range(arrBereiche(i)).Select
Next i
End Sub
Vielen Dank nochmal an eure Hilfe!

Anzeige
AW: Bilder in Excel einfügen
11.10.2012 15:57:49
JoWE
so gehts:
Sub get_jpgFiles()
Set fso = CreateObject("Scripting.Filesystemobject")
Set ordner = fso.GetFolder("\\s19pblafs01\Home\nw023033\Eigene Bilder\")
For Each fsoFile In ordner.Files
ext = LCase(fso.GetExtensionName(fsoFile))
If ext = "jpg" Then
i = i + 1
ActiveWorkbook.ActiveSheet.Cells(i, 1) = _
fso.GetBaseName(fsoFile) & ".jpg"
End If
Next
End Sub

AW: Bilder in Excel einfügen
11.10.2012 15:56:46
JoWE
Sub Pfadbilder()
'Schreibt PfadBilder
Set FSO = CreateObject("Scripting.Filesystemobject")
Set Ordner = FSO.GetFolder(PfadBilder)
For Each datei In Ordner.Files
anzahldatei = anzahldatei + 1
if left(datei,4) = ".jpg" then
ActiveWorkbook.ActiveSheet.Cells(anzahldatei, 55) = datei
Next
End Sub

Anzeige

316 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige