HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Forumbeitrag
Excel-Version des Fragestellers:
365 Business
Erfahrungslevel des Fragestellers:
VBA nur mit Recorder
peter
22.01.2025 11:13:54
AW: Hilfe-Macro von lokalem Bilder-Import auf URL-Import umbauen
Hallo



If Dir(strBildPfad) = "" Then
nBildInZelleEinfuegen = 4
Exit Function
End If



Diese Teil funktioniert mit einer URL nicht. Einfach auskommentieren. dann sollt alles funktionieren.

Peter
Als Antwort auf diesen Beitrag
Sascha Zorz
22.01.2025 10:44:27
Hilfe-Macro von lokalem Bilder-Import auf URL-Import umbauen
Hallo Excel Gemeinde,

folgendes Excel-Macro https://www.herber.de/bbs/user/175027.xlsm zum einfügen von Artikelbildern habe ich von unserem Vorgänger hier im Unternehmen geerbt.
Diese Datei ist sehr beliebt bei den Kollegen und wird Abteilungsübergreifend auch mehrfach am Tag genutzt.
Nun bin ich selbst kein Excel\VBA Expert und komme eigentlich über den Macro-Recorder auch nicht hinaus, finde daher den entscheidenden Hinweis auch nicht,
den ich mir hier von einem Experten erhoffe?.

Hintergrund zu der Datei: Im Tabellenblatt "BilderImport" in Spalte A stehen z.B Artikelnummern und in Spalte B ein lokaler Pfad bis hin zum Bilddateinamen.
In diese Zellen wo ein lokaler BilderPfad hinterlegt ist, fügt das Macro dann auch sauber die Bilder aus diesem Pfad dann ein, wenn man im Tabellenblatt2 "Bearbeitung starten" auf "Bilder laden..." klickt. Soweit so gut all die Jahre.

Was sich nun aber geändert hat, ist das wir unsere Artikelbilder zukünftig nicht mehr lokal im Filesystem ablegen werden sondern online in der Cloud.
Jedes Bild hat dann logischerweise auch eine individuelle URL. Als Test habe ich in Spalte B einfach mal URL-Pfade zu den Bilder eingetragen (siehe Beispieldatei).
Starte ich jetzt aber das Macro wie gewohnt, läuft es sofort auf einen Fehler. (siehe Screenshot: https://www.herber.de/bbs/user/175028.png )
Bräuchte also jemand der mir helfen könnte den VBA-Code umzubauen, damit auch URL-Pfade für den Bilderimport dort funktionieren.?

Vielen lieben Dank schon einmal vorab für euer Feedback.

Hier auch noch einmal der Code im Klartext, sowie er in der Beispiel 175027.xlsm oben hinterlegt ist :

Function nBildInZelleEinfuegen(strSpalteBilderPfad As String, nSpalteBilderpfad As Long, nZeileBilderPfad As Long, nZielZelleBreite As Long, nZielZelleHoehe As Long, wks As Worksheet) As Long
On Error GoTo Fehler

Dim strBildPfad As String
Dim nAbstandBilderZuZelleLinksOben As Long '004
Dim nAbstandBilderZuZelleRechtsUnten As Long '004

nBildInZelleEinfuegen = 0
strBildPfad = wks.Cells(nZeileBilderPfad, nSpalteBilderpfad)

If Trim(strBildPfad) = "" Then
nBildInZelleEinfuegen = 2
Exit Function
End If

If TypeName(ActiveSheet) <> "Worksheet" Then
nBildInZelleEinfuegen = 3
Exit Function
End If

If Dir(strBildPfad) = "" Then
nBildInZelleEinfuegen = 4
Exit Function
End If

wks.Activate
wks.Select
' Spaltenbreite : 0 - 255, 1 = 8.43 Character
' Zeilenhöhe : 0 to 449, 1 = 0.035 cm
strZelle = strSpalteBilderPfad & CStr(nZeileBilderPfad)
wks.Range(strZelle).Select
wks.Range(strZelle).RowHeight = nZielZelleHoehe
wks.Range(strZelle).ColumnWidth = nZielZelleBreite

nAbstandBilderZuZelleLinksOben = Range("B6") '004 Eingabefeld
nAbstandBilderZuZelleRechtsUnten = Range("B7") '004 Eingabefeld

With wks.Range(strZelle)
'wks.Shapes.AddPicture strBildPfad, False, True, .Left, .Top, .Width, .Height '004
wks.Shapes.AddPicture strBildPfad, False, True, .Left + nAbstandBilderZuZelleLinksOben, .Top + nAbstandBilderZuZelleLinksOben, .Width - nAbstandBilderZuZelleRechtsUnten, .Height - nAbstandBilderZuZelleRechtsUnten '004
'.Value = ""'004
End With

Ende:

Exit Function

Fehler:
MsgBox "Fehler in nBildInZelleEinfuegen! " & Err.Description, vbCritical
nBildInZelleEinfuegen = 1
GoTo Ende
End Function

Private Sub cmdBilderLaden_Click()
Dim strBildPfad As String
Dim nRow As Long
Dim strNameSheetBilderpfad As String
Dim nZeileBilderPfad As Long
Dim nSpalteBilderpfad As Long
Dim strZelleBild As String
Dim wks As Worksheet
Dim wksBilder As Worksheet
Dim strSpalteBilderPfad As String
Dim nHoeheBilder As Long
Dim nBreiteBilder As Long
Dim nAnzahlTest As Long

'Bildpfad aus Zelle auslesen!
strBildPfad = Range("c3")
'Name Sheet
strNameSheetBilderpfad = Range("B5") 'Eingabefeld

For Each wks In Worksheets
If Trim(wks.Name) = Trim(strNameSheetBilderpfad) Then
Set wksBilder = wks
Exit For
End If
Next wks

'Zeile - Bilderpfad
nZeileBilderPfad = Range("B4") 'Eingabefeld
nRow = nZeileBilderPfad

'Spalte - Bilderpfad
strSpalteBilderPfad = Range("B3") 'Eingabefeld
nSpalteBilderpfad = Range("B3").Column

'Bild - Höhe
nHoeheBilder = Range("B1") 'Eingabefeld

'Bild - Breite
nBreiteBilder = Range("B2") 'Eingabefeld

Sheets(strNameSheetBilderpfad).Select ' Bilder-Sheet aktivieren!

' Alle Bilder löschen, die als Name mit Picture beginnen
For i = 0 To wksBilder.Shapes.Count - 1
If bDelete Then
bDelete = False
If wksBilder.Shapes.Count = 0 Then Exit For
i = -1
Else
If Left(wks.Shapes(i + 1).Name, 7) = "Picture" Then
wks.Shapes(i + 1).Delete
bDelete = True
End If
End If
Next i

nAnzahlTest = 0
' Bilderdateien durchlaufen und in die Zellen einfügen bis 10 Leere Zellen in den Bildpfad-Zelle vorkommt!
While Not IsEmpty(Sheets(strNameSheetBilderpfad).Cells(nRow, nSpalteBilderpfad)) Or nAnzahlTest < 10
nAnzahlTest = nAnzahlTest + 1
If nBildInZelleEinfuegen(strSpalteBilderPfad, nSpalteBilderpfad, nRow, nBreiteBilder, nHoeheBilder, wksBilder) = 0 Then
nAnzahlTest = 0
End If
nRow = nRow + 1
Wend
End Sub

Folgenachrichten
Antwort auf Beitrag erstellen

Beispieldatei hochladen