Bild einfügen klappt nicht
11.05.2016 18:48:08
Oisse
ich würde Folgendes gerne realisieren.
In einem Ordner sind Bilder hinterlegt. Die Namen der Bilder setzen sich zusammen aus der Tabelle "Artikel", Spalte 11 und Spalte 12 mit einem Unterstrich dazwischen.
Wenn nun die einzelnen Artikel entweder durch einen gesetzten Filter oder aber durch manuelle Auswahl selektiert sind, dann sollen dazu die Bilder eingefügt werden oder aber, wenn kein Bild vorhanden ist, der Text: "Bild fehlt!"
Folgenden Code habe ich bereits zusammengeschnipselt. Allerdings funktioniert er so nicht.
Könnte bitte mal jemand drüber schauen?
Private Sub OptionButton1_Click()
Dim lPathCol As String ' Verzeichnis
Dim lPicNameCol As String ' Bildname
Dim lPicCol As Long ' Spalte in der Bild erscheinen soll
Dim lRow As Range
Dim rng_Row As Range
Dim int_Counter As Integer
Dim wks_Ang As Worksheet
Dim wks_Art As Worksheet
Dim Text As String
Tbl1 = "Angebote"
Tbl2 = "Artikel"
lPathCol = ThisWorkbook.Path & "\Images"
lPicCol = 24
Set wks_Ang = ThisWorkbook.Worksheets(Tbl1)
Set wks_Art = ThisWorkbook.Worksheets(Tbl2)
'If Target.Column > 1 Or Target.Count > 1 Then Exit Sub
'If IsEmpty(Target) Then Exit Sub
On Error Resume Next
wks_Art.Pictures.Delete
On Error GoTo 0
If wks_Art.AutoFilter.FilterMode = True Then 'Prüfen ob der Autofilter gesetzt ist, wenn _
ja, dann:
ActiveSheet.Range("A3:W" & ActiveSheet.UsedRange.Rows.Count). _
SpecialCells(xlCellTypeVisible).Select 'alle sichtbaren Zeilen _
selektieren
For Each lRow In Selection.Rows
lPicNameCol = wks_Art.Cells(lRow.Row, 11) & "_" & wks_Art.Cells(lRow.Row, 12)
If Dir(Cells(lRow.Row, lPathCol).Text & "\" & Cells(lRow.Row, lPicNameCol).Text) = _
"" Then 'Hier kommt die Fehlermeldung "Typen unverträglich"
Cells(lRow.Row, lPicCol) = "Bild fehlt!"
Else
Cells(lRow.Row, lPicCol).ClearContents
With Pictures.Insert(Cells(lRow.Row, lPathCol).Text & "\" & Cells(lRow.Row, _
lPicNameCol).Text)
'Anpassen an die Zellegrösse
.Top = Rows(lRow).Top
.Height = Rows(lRow).Height
.Left = Columns(lPicCol).Left
.Width = Columns(lPicCol).Width
End With
End If
Next lRow
Cancel = True
Else
For Each lRow In Selection.Rows
lPicNameCol = wks_Art.Cells(lRow.Row, 11) & "_" & wks_Art.Cells(lRow.Row, 12)
If Dir(Cells(lRow.Row, lPathCol).Text & "\" & Cells(lRow.Row, lPicNameCol).Text) = _
"" Then
Cells(lRow.Row, lPicCol) = "Bild fehlt!"
Else
Cells(lRow.Rows, lPicCol).ClearContents
With Pictures.Insert(Cells(lRow.Rows, lPathCol).Text & "\" & Cells(lRow.Rows, _
lPicNameCol).Text)
'Anpassen an die Zellegrösse
.Top = Rows(lRow).Top
.Height = Rows(lRow).Height
.Left = Columns(lPicCol).Left
.Width = Columns(lPicCol).Width
End With
End If
Next lRow
Cancel = True
Vielen Dank schon mal