Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Linksklick in Zelle Bild einfügen

Linksklick in Zelle Bild einfügen
06.08.2021 18:08:43
oraculix
Hallöchen Alle
Ich bräuchte ein Macro das bei Linksklick in beliebiger Zelle Spalte B ein Bild in Image1 einfügt.
(vorher sollte das alte Bild gelöscht werden falls eins drinnen ist)
Die Bilder mit dem gleichen Namen wie in Spalte B liegen in "D:\EMDB\HTML\ExcelCovers\"
Hier ein ungefähres Macro das noch etwas angepasst werden sollte.
Danke
https://www.herber.de/bbs/user/147492.xlsm

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const FOLDER_PATH As String = "D:\EMDB\HTML\ExcelCovers\"
Dim strFilename As String
Dim objCell As Range
Dim objImage1 As Shape
For Each objCell In Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp))
If objCell.Image1 Is Nothing Then
Set objImage1 = objCell.AddImage1
Else
Set objImage1 = objCell.Image1
End If
Call objImage1(Text:="", Start:=1)
strFilename = Dir$(FOLDER_PATH & objCell.Text & ".*")
If strFilename  vbNullString Then
With objImage1.Shape
Call .Fill.UserPicture(PictureFile:=FOLDER_PATH & strFilename)
.Width = 260
.Height = 323
End With
End If
Next
Set objImage1 = Nothing
End Sub
Gruß
Oraculix

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Linksklick in Zelle Bild einfügen
06.08.2021 19:05:15
Nepumuk
Hallo,
füge ein Image-Control in der gewünschten Größe in die Tabelle ein. In das Modul der Tabelle dann folgender Code:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const FOLDER_PATH As String = "D:\EMDB\HTML\ExcelCovers\"
Dim strFilename As String
Dim objCell As Range
Set objCell = Target.Cells(1, 1)
If Not Intersect(objCell, Columns(2)) Is Nothing Then
strFilename = Dir$(FOLDER_PATH & objCell.Text & ".*")
If strFilename  vbNullString Then
With OLEObjects("Image1")
.Top = objCell.Top
.Left = objCell.Left + objCell.Width
.Visible = True
Set .Object.Picture = LoadPicture(Filename:=FOLDER_PATH & strFilename)
End With
Else
OLEObjects("Image1").Visible = False
End If
Else
OLEObjects("Image1").Visible = False
End If
Set objCell = Nothing
End Sub
Gruß
Nepumuk
Anzeige
AW: Genial Danke
06.08.2021 19:21:06
oraculix
Ja Vielen Dank ist viel Besser als in Kommentar einfügen weil sonst die Mappe zerplatzt mit der Größe, aber man lern ja nie aus.
Gruß
Oraculix
Ps: Dein Guthaben haste noch nicht bestellt!!
AW: Genial Danke
06.08.2021 19:30:25
Nepumuk
Hallo,
na dann, hast du die sechsteilige Serie: Per Anhalter durch die Galaxis ?
Gruß
Nepumuk
AW: Genial Danke
06.08.2021 20:05:24
oraculix
Wenn es die von 1981 ist dann ist sie bei Dir!
Danke
Gruß
Oraculix
AW: Genial Danke
06.08.2021 20:16:10
Nepumuk
Hallo,
Super, danke.
Gruß
Nepumuk

417 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige