Code-Fehler Verlinken zu Bildern

Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' Action 1: displays matching picture to data in column C when clicking on it ' Action 2: deletes displayed picture if mouse click elsewhere than column c Dim varBild If Target.Column = 3 Then If Target.Count = 1 Then If Target "" Then If Dir("C:\Users\Notebook\Desktop\My Documents\Bilder\" & Target.Value & ".jpg") _ "" Then If ActiveSheet.Pictures.Count > 0 Then ActiveSheet.Pictures(1).Delete Set varBild = ActiveSheet.Shapes.AddPicture("C:\Users\Notebook\Desktop\My _ Documents\Bilder\" & _ Target & ".jpg", True, True, Range("I8").Left, Range("I8").Top, 230, 230) Set varBild = Nothing End If End If End If Else If ActiveSheet.Pictures.Count > 0 Then ActiveSheet.Pictures(1).Delete End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit Const imagePath As String = "C:\Users\Notebook\Desktop\My Documents\Bilder\" 'Stammverzeichnis der Bilder Const MaxWidth As Long = 230 'Maximale Breite des Bildes Const MaxHeight As Long = 180 'Maximale Höhe des Bildes Private objImg As Object Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' ' Action 1: displays matching picture to data in column C when clicking on it ' Action 2: deletes displayed picture if mouse click elsewhere than column c ' Dim dblWidth As Double, dblHeight As Double If Not objImg Is Nothing Then objImg.Visible = False DoEvents If Target.Column = 3 And Target.Count = 1 Then If Target <> "" Then If Dir(imagePath & IIf(Right(imagePath, 1) <> "\", "\", "") & Target.Value & ".jpg") <> "" Then On Error Resume Next If objImg Is Nothing Then Set objImg = Me.OLEObjects("imageContainer") On Error GoTo 0 If objImg Is Nothing Then createImageContainer With objImg .Object.AutoSize = True .Object.Picture = LoadPicture(imagePath & IIf(Right(imagePath, 1) <> "\", "\", "") & Target.Value & ".jpg") .Top = Target.Top .Left = Target.Left + Target.Width If .Height > MaxHeight Or .Width > MaxWidth Then .Object.AutoSize = False dblWidth = MaxWidth / .Width dblHeight = MaxHeight / .Height If dblWidth < dblHeight Then .Width = .Width * dblWidth .Height = .Height * dblWidth Else .Width = .Width * dblHeight .Height = .Height * dblHeight End If End If .Visible = True End With Else If Not objImg Is Nothing Then objImg.Visible = False DoEvents MsgBox "Kein Bild vorhanden!" End If Else If Not objImg Is Nothing Then objImg.Visible = False End If Else If Not objImg Is Nothing Then objImg.Visible = False End If End Sub Private Sub createImageContainer() Set objImg = Me.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _ DisplayAsIcon:=False, Left:=0, Top:=0, Width:=0, Height:=0) With objImg .Visible = False .Object.PictureSizeMode = 1 .Name = "imageContainer" End With End Sub

Hallo Sepp,
vielen vielen Dank dafür - das klappt super und Du hast Dir so viel Arbeit damit gemacht !!
Ich habe nur noch zwei kleine Fragen dazu - vielleicht hast Du ja auch dazu noch eine Idee ? :-)
1) Zuvor hatte mein Code am Ende eine Zeile enthalten, die angezeigte Bilder (bzw. jetzt auch die super Message Box) automatisch wieder verschwinden ließ, wenn man irgendwo in eine andere Spalte als C geklickt hat, was jetzt nicht mehr klappt - hast Du dazu auch eine Idee ?
2) Die Bilder erscheinen jetzt direkt neben der angeklickten Zelle, was schön aussieht, solange die Zelle nicht relativ weit unten auf dem Blatt erscheint.
Kann man hier auch sagen, dass die Bilder immer an einem bestimmten Punkt des Blattes (z.B. einer Zelle) erscheinen sollen ?
LG und nochmals vielen Dank für die super Hilfe,
Jenny

Hallo Jenny,
dass das Bild nicht ausgeblendet wird wenn eine Zelle außerhalb von Spalte C angeklickt wird, kann ich nicht nachvollziehen.
Zu Punkt 2: Mit den Konstanten PosLeft und PosTop kannst du die Position des Bildes festlegen.

' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const imagePath As String = "C:\Users\Notebook\Desktop\My Documents\Bilder\" 'Stammverzeichnis der Bilder
Const MaxWidth As Long = 230 'Maximale Breite des Bildes
Const MaxHeight As Long = 180 'Maximale Höhe des Bildes
Const PosLeft As Long = 250 'Position von Links
Const PosTop As Long = 50 'position von Oben

Private objImg As Object

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  '
  ' Action 1: displays matching picture to data in column C when clicking on it
  ' Action 2: deletes displayed picture if mouse click elsewhere than column c
  '
  Dim dblWidth As Double, dblHeight As Double
  
  If Not objImg Is Nothing Then objImg.Visible = False
  DoEvents
  
  If Target.Column = 3 And Target.Count = 1 Then
    If Target <> "" Then
      If Dir(imagePath & IIf(Right(imagePath, 1) <> "\", "\", "") & Target.Value & ".jpg") <> "" Then
        On Error Resume Next
        If objImg Is Nothing Then Set objImg = Me.OLEObjects("imageContainer")
        On Error GoTo 0
        If objImg Is Nothing Then createImageContainer
        With objImg
          .Object.AutoSize = True
          .Object.Picture = LoadPicture(imagePath & IIf(Right(imagePath, 1) <> "\", "\", "") & Target.Value & ".jpg")
          .Top = PosTop
          .Left = PosLeft
          If .Height > MaxHeight Or .Width > MaxWidth Then
            .Object.AutoSize = False
            dblWidth = MaxWidth / .Width
            dblHeight = MaxHeight / .Height
            If dblWidth < dblHeight Then
              .Width = .Width * dblWidth
              .Height = .Height * dblWidth
            Else
              .Width = .Width * dblHeight
              .Height = .Height * dblHeight
            End If
          End If
          .Visible = True
        End With
      Else
        If Not objImg Is Nothing Then objImg.Visible = False
        DoEvents
        MsgBox "Kein Bild vorhanden!"
      End If
    Else
      If Not objImg Is Nothing Then objImg.Visible = False
    End If
  Else
    If Not objImg Is Nothing Then objImg.Visible = False
  End If
  
End Sub



Private Sub createImageContainer()
  
  Set objImg = Me.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
    DisplayAsIcon:=False, Left:=0, Top:=0, Width:=0, Height:=0)
  
  With objImg
    .Visible = False
    .Object.PictureSizeMode = 1
    .Name = "imageContainer"
  End With
  
End Sub

« Gruß Sepp »

' ********************************************************************** ' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit Const imagePath As String = "E:\Bilder\Diverses\Test" '"C:\Users\Notebook\Desktop\My Documents\Bilder\" 'Stammverzeichnis der Bilder Const MaxWidth As Long = 230 'Maximale Breite des Bildes Const MaxHeight As Long = 180 'Maximale Höhe des Bildes Const PosLeft As Long = 250 'Position von Links Const PosTop As Long = 50 'position von Oben Private objImg As Object Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' ' Action 1: displays matching picture to data in column C when clicking on it ' Action 2: deletes displayed picture if mouse click elsewhere than column c ' Dim dblWidth As Double, dblHeight As Double Dim strFile As String If Not objImg Is Nothing Then objImg.Visible = False DoEvents If Target.Column = 3 And Target.Count = 1 Then If Target <> "" Then strFile = imagePath & IIf(Right(imagePath, 1) <> "\", "\", "") & Target.Value & ".jpg" strFile = Replace(Replace(strFile, vbLf, ""), vbCrLf, "") If Dir(strFile) <> "" Then On Error Resume Next If objImg Is Nothing Then Set objImg = Me.OLEObjects("imageContainer") On Error GoTo 0 If objImg Is Nothing Then createImageContainer With objImg .Object.AutoSize = True .Object.Picture = LoadPicture(strFile) .Top = ActiveWindow.VisibleRange.Top + PosTop .Left = PosLeft If .Height > MaxHeight Or .Width > MaxWidth Then .Object.AutoSize = False dblWidth = MaxWidth / .Width dblHeight = MaxHeight / .Height If dblWidth < dblHeight Then .Width = .Width * dblWidth .Height = .Height * dblWidth Else .Width = .Width * dblHeight .Height = .Height * dblHeight End If End If .Visible = True End With Else If Not objImg Is Nothing Then objImg.Visible = False DoEvents MsgBox "Kein Bild vorhanden!" End If Else If Not objImg Is Nothing Then objImg.Visible = False End If Else If Not objImg Is Nothing Then objImg.Visible = False End If End Sub Private Sub createImageContainer() Set objImg = Me.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _ DisplayAsIcon:=False, Left:=0, Top:=0, Width:=0, Height:=0) With objImg .Visible = False .Object.PictureSizeMode = 1 .Name = "imageContainer" End With End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' Action 1: displays matching image when clicking on corresponding entry in column C ' Action 2: deletes displayed image if mouse click elsewhere than column C Dim dblWidth As Double, dblHeight As Double Dim strFile As String If Not objImg Is Nothing Then objImg.Visible = False DoEvents If Target.Column = 3 And Target.Count = 1 Then If Target "" Then strFile = imagePath & IIf(Right(imagePath, 1) "\", "\", "") & Target.Value & ".jpg" strFile = Replace(Replace(strFile, vbLf, ""), vbCrLf, "") If Dir(strFile) "" Then On Error Resume Next If objImg Is Nothing Then Set objImg = Me.OLEObjects("imageContainer") On Error GoTo 0 If objImg Is Nothing Then createImageContainer With objImg .Object.AutoSize = True .Object.Picture = LoadPicture(strFile) .Top = ActiveWindow.VisibleRange.Top + PosTop .Left = PosLeft If .Height > MaxHeight Or .Width > MaxWidth Then .Object.AutoSize = False dblWidth = MaxWidth / .Width dblHeight = MaxHeight / .Height If dblWidth

Private Sub createImageContainer() Set objImg = Me.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _ DisplayAsIcon:=False, Left:=0, Top:=0, Width:=0, Height:=0) With objImg .Visible = False .Object.PictureSizeMode = 1 .Name = "imageContainer" End With End Sub

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code-Fehler Verlinken zu Bildern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread