Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1264to1268
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
Bilder (JPG) aus Verzeichnis einfügen
Dieter(Drummer)
Hi Spezialisten,
per VBA möchte ich aus einem frei wählbaren Verzeichnis - dort sind nicht nur Bilddateien - alle Bilder (nur JPG's) in einer frei wählbaren Bildgrösse in ein Tabellenblatt einfügen. Die Bilder können dann untereinander - mit geringem Abstand eingefügt werden. Ist das Ende des Tabellenblattes erreicht, sollen die nächsten Bilder wieder oben rechts - neben den bereits eingefügten - weiter eingefügt werden.
Freue mich auf eine Lösung und Danke für's drum kümmern.
Mit Gruß, Dieter(Drummer)
PS - Bilder per VBA als Hyperlink, aus frei wählbarem Verzeichnis, in Spalte A einfügen und dann per Hyperlink aufrufen habe ich und geht prima.
AW: Bilder (JPG) aus Verzeichnis einfügen
12.06.2012 21:08:32
Josef

Hallo Dieter,
dir ist aber klar, dass Excel als Bildbetrachter eher ungeeignet ist.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Const IMAGE_HEIGHT As Long = 45 'Bildhöhe
Private Const FIRST_IMAGE_TOP As Long = 15 'Startposition von oben
Private Const FIRST_IMAGE_LEFT As Long = 20 'Startposition von links
Private Const SPACE_H As Long = 5 'Horizontaler Abstand
Private Const SPACE_V As Long = 5 'Vertikaler Abstand
Private Const MAX_IMAGES_IN_COL As Long = 15 'Maximale Bilderanzahl pro Spalte

Sub insertPictures()
  Dim objImg As Object
  Dim strPath As String, strImg As String
  Dim dblTop As Double, dblLeft As Double, dblMaxWidth As Double
  Dim lngIndex As Long, lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  dblTop = FIRST_IMAGE_TOP
  dblLeft = FIRST_IMAGE_LEFT
  
  strPath = fncBrowseForFolder
  
  If Len(strPath) Then
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
    strPath = strPath & "\"
    strImg = Dir(strPath & "*.jpg", vbNormal)
    Do While strImg <> ""
      Set objImg = ActiveSheet.Pictures.Insert(strPath & strImg)
      With objImg
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = IMAGE_HEIGHT
        .Left = dblLeft
        .Top = dblTop
        lngIndex = lngIndex + 1
        dblMaxWidth = Application.Max(dblMaxWidth, .Width)
      End With
      If lngIndex Mod MAX_IMAGES_IN_COL = 0 Then
        dblTop = FIRST_IMAGE_TOP
        dblLeft = dblLeft + dblMaxWidth + SPACE_H
        dblMaxWidth = 0
      Else
        dblTop = dblTop + IMAGE_HEIGHT + SPACE_V
      End If
      strImg = Dir
    Loop
  End If
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'insertPictures'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
  Set objImg = Nothing
End Sub



Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application")
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
  ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function



« Gruß Sepp »

Anzeige
AW: Bilder (JPG) aus Verzeichnis einfügen
12.06.2012 21:25:16
Dieter(Drummer)
Danke Sepp,
für deine schnelle Hilfe. Mir ist klar, dass Excel nicht der optimale Bildbetrachter ist.
Habe dein Makro laufen lassen und ich kann wohl vor dem laden/einfügen der Bilder die Größe nicht bestimmen. Sie werden in schmalem Format eingefügt und ich müsste sie alle einzeln zu einer Grüße, z.B. 5 cm Höhe (daraus ergibt sich dann die Breite) ändern.
Ist es möglich, noch eine optionale Größe - vor dem jeweiligen einfügen des Bildes ) es sind mehrere Bilder- anzugeben? Wäre toll, wenn es möglich wäre.
Trotzdem Danke für deine Hilfe.
Gruß, Dieter(Drummer)
AW: Bilder (JPG) aus Verzeichnis einfügen
12.06.2012 21:35:14
Josef

Hallo Dieter,
wofür ist wohl die Konstante "IMAGE_HEIGHT"?

« Gruß Sepp »

Anzeige
AW: Sepp, Danke für Info und Hilfe ...
12.06.2012 21:43:27
Dieter(Drummer)
... werde mit den Angaben experimentieren.
Danke für deine Hilfe inf Zusatz Info.
Gruß und einen schönen Restabend, Dieter(Drummer)
AW: Frage:Wie kann ich Breite einstellen ...
12.06.2012 22:11:26
dieter(Drummer)
... Sepp, wo kann ich in deinem Makro denn die Breite der Bilder einstellen. Habe prbiert und kriege es nicht hin.
Evtl. Antwort muss nicht mehr HEUTE sein.
Gruß, Dieter(Drummer)
AW: Frage:Wie kann ich Breite einstellen ...
12.06.2012 22:18:42
Josef

Hallo Dieter,
wenn du die Breite der Bilder ebenfalls anpassen willst, werden die Bilder allerdings verzerrt weil das Seitenverhältnis nicht mehr stimmt.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Const IMAGE_HEIGHT As Long = 45 'Bildhöhe
Private Const IMAGE_WIDTH As Long = 175 'Bildbreite
Private Const FIRST_IMAGE_TOP As Long = 15 'Startposition von oben
Private Const FIRST_IMAGE_LEFT As Long = 20 'Startposition von links
Private Const SPACE_H As Long = 5 'Horizontaler Abstand
Private Const SPACE_V As Long = 5 'Vertikaler Abstand
Private Const MAX_IMAGES_IN_COL As Long = 3 '15 'Maximale Bilderanzahl pro Spalte

Sub insertPictures()
  Dim objImg As Object
  Dim strPath As String, strImg As String
  Dim dblTop As Double, dblLeft As Double ', dblMaxWidth As Double
  Dim lngIndex As Long, lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  dblTop = FIRST_IMAGE_TOP
  dblLeft = FIRST_IMAGE_LEFT
  
  strPath = fncBrowseForFolder
  
  If Len(strPath) Then
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
    strPath = strPath & "\"
    strImg = Dir(strPath & "*.jpg", vbNormal)
    Do While strImg <> ""
      Set objImg = ActiveSheet.Pictures.Insert(strPath & strImg)
      With objImg
        .ShapeRange.LockAspectRatio = msoFalse
        .Height = IMAGE_HEIGHT
        .Width = IMAGE_WIDTH
        .Left = dblLeft
        .Top = dblTop
        lngIndex = lngIndex + 1
        'dblMaxWidth = Application.Max(dblMaxWidth, .Width)
      End With
      If lngIndex Mod MAX_IMAGES_IN_COL = 0 Then
        dblTop = FIRST_IMAGE_TOP
        dblLeft = dblLeft + IMAGE_WIDTH + SPACE_H
        'dblMaxWidth = 0
      Else
        dblTop = dblTop + IMAGE_HEIGHT + SPACE_V
      End If
      strImg = Dir
    Loop
  End If
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'insertPictures'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
  Set objImg = Nothing
End Sub



Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application")
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
  ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function



« Gruß Sepp »

Anzeige
AW: Danke Sepp, so komm ich weiter ...
12.06.2012 22:40:06
Dieter(Drummer)
... die Höhe und Breite pass ich nun im Makro an. Probelauf ist schon prima.
Danke dir für deine späte und prima Hilfe. Dass die Höhe und Breite VOR jedem Bild eingefügt/angegeben werden könnte, z.B. für eine Inputbox, würde wohl den Aufwand sprengen. Ich bin schon mit deiner jetzigen Hilfe zufrieden. Danke dir!
Schönen Abend und Gruß, Dieter(Drummer)
AW: Danke Sepp, so komm ich weiter ...
13.06.2012 20:04:49
Josef

Hallo Dieter,
vor jedem Bild die Dimensionen abfragen ist kein Problem, ob es bei mehreren Bildern praktisch ist musst du selber wissen. Wenn du es willst, dann baue ich es dir gerne ein.

« Gruß Sepp »

Anzeige
AW: Würde es gerne ausprobieren ...
13.06.2012 22:00:33
Dieter(Drummer)
... Sepp. Danke schonmal für weiteres Interesse für mein Anliegen.
Wäre noch toll, wenn ich die Größen (Höhe/Breite) in cm eingeben könnte. Wenn ich das richtig sehe, sind jetzt die Angaben in deinem Makro für die Höhe und Breite in Punkt angegegeben. Es könnte aber auch in Punkt bleiben, wenn es die Sache verkompliziert. Die Spitze wäre, wenn die Bildgröße beim Einladen angezeigt wird und dann kann mann die neue gewünschte Größe eingeben, die dann auch eingesetzt wird.
Ich hoffe meine Wünsche sind nicht unverschämt. Ich sehe, welcher Aufwand damit verbunden ist. Das Ergebnis ist evtl, auch für Andere interessant.
Freue mich auf deine neue Variante, aber bitte KEIN Stress.
Gruß aus Düsseldorf beim Fussballstand 2:0 für Deutschland/Holland, Dieter(Drummer)
Anzeige
AW: Würde es gerne ausprobieren ...
13.06.2012 22:15:31
Josef

Hallo Dieter,
kurze Rückfrage. Die Größenabfrage für jeder Bild einzeln oder einmal für alle Bilder?

« Gruß Sepp »

AW: Für jedes Bild einzeln ... owT
13.06.2012 22:23:11
Dieter(Drummer)
.
AW: Für jedes Bild einzeln ... owT
13.06.2012 23:39:24
Josef

Hallo Dieter,
anbei ein ausbaufähiges Beispiel.
https://www.herber.de/bbs/user/80553.xls

« Gruß Sepp »

Anzeige
AW: Danke Sepp! Prima Lösung ...
14.06.2012 00:13:39
Dieter(Drummer)
... damit kann ich was anfangen.
Danke dir für deinen unermüdlichen Einsatz und die fertige Lösung. Es funktioniert prima.
Wünsche dir eine gute Nacht und nochmal DANKE, Dieter(Drummer)
AW: Einfach eine tolle Lösung ...
14.06.2012 09:13:52
Dieter(Drummer)
... Guten Morgen Sepp,
da hast du mir ein prima Ergebnis geliefert. Ich kann nur ahnen, mit welchem Aufwand so ein Makro enstanden ist und das noch zu so gestrigen, späten Stunde. Dir und auch Nepumuk - der im Makro auch genannt ist - herzlichen Dank.
Wenn ich die angezeigten - im Klammer stehenden - cm Angaben mit dem Divisor 10 eingebe, hat das Bild beim einfügen eine Größe, die meinen Vorstellungen entspricht.

Nun möchte ich noch eine Bitte äußern
. Wenn auf der Userform, neben der TXT-Box "txtH" noch ein z.B. "Drehfeld" eingefügt wäre, dass es möglich macht, die cm-Angaben per Divisior in die beiden TXT-Boxen "txtW" (Neue Breite) und "txtH" (Neue Höhe) zu verändern, bin ich restlos zufrieden. So könnte ich per Drehfeld die cm-Eingaben in den beiden Textboxen kleiner/größer einfügen. Die Schrittweite des Drehfeldes kann z.B. in frei wählbaren Divisionsschritten, z.B. 2, 3, 4 etc. bis 99, gehen. Durch betätigen des Drehfeldes ändern sich jeweils dann die Eingaberwerte in den beiden Txt-Boxen.
Ich hoffe, dass ich hier nicht zu viel wünsche. Wenn dies noch geht, wäre TOLL!
Gruß und nochmal Danke für die bisherige PRIMA Lösung, Dieter(Drummer)
Anzeige
AW: Beispiel mit Bildvorschau ...
14.06.2012 16:36:03
Dieter(Drummer)
... Hi Sepp,
habe in deiner Beispielversion die Userform so angepasst, dass nun die Bilder in der Vorschau komplett zu sehen sind, bevor diese eingefügt werden. Das wäre mir natürlich ohne deine Vorbereitung nicht gelungen. Funktioniert prima!

Die Datei https://www.herber.de/bbs/user/80567.xls wurde aus Datenschutzgründen gelöscht


Übrigens ein zusätzliches Drehfeld neben der TXT.Boxen, um die neue Größe zu verwenden, wäre ich auch schon mit Drehfeldsprüngen in je 5er Divisionssprüngen zufrieden. das bedeutet, wenn z.B. 123,4 angezeigt wird, soll mit Drehfeld z.B. 12,34 möglich sein (Divisor 10). Wäre schön, wenn das noch zu machen wäre.
Bin immer noch fasziniert wir prima das bisher schon funktioniert.
Danke und Gruß für eventuelle Erweiterung, Dieter(Drummer
Anzeige
AW: Sepp, wieder hervorragend gelöst ...
14.06.2012 19:00:07
Dieter(Drummer)
... Danke dir für die excelente Lösung. Klappt prima!
Nochmal meine Dank für deinen Einsatz und die perfekte Endlösung.
Gruß und einen erfolgreichen Resttag, Dieter(Drummer)
Anzeige

108 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige