Bild einfügen mit autom. Größenanpassung

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim var As Variant Dim sFiles As String sFiles = "Grafikdateien (*.bmp), *.bmp, " sFiles = sFiles & "Grafikdateien (*.gif), *.gif, " sFiles = sFiles & "Grafikdateien (*.jpg), *.jpg" On Error Resume Next var = Application.GetOpenFilename(sFiles) ActiveSheet.Pictures.Insert var End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub insert_picture() Dim pic As Picture Dim path As Variant Dim sFiles As String sFiles = "Grafikdateien (*.bmp), *.bmp, " sFiles = sFiles & "Grafikdateien (*.gif), *.gif, " sFiles = sFiles & "Grafikdateien (*.jpg), *.jpg" path = Application.GetOpenFilename(sFiles) If (path = False) Then Exit Sub Set pic = ActiveSheet.Pictures.Insert(path) With pic .Width = 300 .Height = 450 .Top = 150 .Left = 50 End With End Sub

Hallo Karin!
Probier mal!

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

Option Explicit
Const maxWidth As Double = 120 'Bildbreite
Const maxHeight As Double = 90 'Bildhöhe

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strFile As String, strParam As String
Dim objPic As Picture
Dim rngAnchor As Range

Cancel = True

Set rngAnchor = Target ' oder = Range("B2") 'Zelle als Bezugspunkt zum einfügen!

strParam = "Grafikdateien (*.bmp), *.bmp, "
strParam = strParam & "Grafikdateien (*.gif), *.gif, "
strParam = strParam & "Grafikdateien (*.jpg), *.jpg"

strFile = Application.GetOpenFilename(strParam)

If strFile = "" Then Exit Sub

Set objPic = ActiveSheet.Pictures.Insert(strFile)

With objPic
  .Top = rngAnchor.Top
  .Left = rngAnchor.Left
  With .ShapeRange
    .LockAspectRatio = msoTrue
    If .Width >= .Height Then
      .Width = maxWidth
    Else
      .Height = maxHeight
    End If
  End With
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Hans,
irgendwie will es mit der Größe des Bildes einfach nicht klappen.
Kann auch gut sein, dass ich den Code irgendwie falsch einbaue...
Muß das Zielfeld auf eine bestimmte Weise formatiert sein?
Wollte einen Bereich aus Zellen verbinden und das Bild hier einfügen. Oder aber innerhalb eines Rahmens platzieren. Eigentlich ist es egal wie, Hauptsache nicht total verzerrt so wie bisher. Die Bilder sind nicht mehr im richtigen Verhältnis von Breite / Höhe und meist viel zu lang gezerrt.
Mit diesen Begrifflichkeiten wie Modul, Prozedur etc. bin ich leider nicht vertraut *peinlich*. Habe das ganze als neues Makro angelegt (bzw. heißt dann "Modul5(Code)".
Aber wahrscheinlich lieg ich da falsch und es muß anders eingefügt werden?
Das ganze sah bei mir wie folgt aus. Vielen Dank wenn ich nochmal Hilfe bekomme...
Grüsse, Karin
------------------------------------------------------------------
(Allgemein) Bild
-----------------------------------------------------------------
Sub Bild()
'
'Option Explicit
Const maxWidth As Double = 120 'Bildbreite
Const maxHeight As Double = 90 'Bildhöhe
End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strFile As String, strParam As String
Dim objPic As Picture
Dim rngAnchor As Range
Cancel = True
Set rngAnchor = Range("G16")
strParam = "Grafikdateien (*.bmp), *.bmp, "
strParam = strParam & "Grafikdateien (*.gif), *.gif, "
strParam = strParam & "Grafikdateien (*.jpg), *.jpg"
strFile = Application.GetOpenFilename(strParam)
If strFile = "" Then Exit Sub
Set objPic = ActiveSheet.Pictures.Insert(strFile)
With objPic
.Top = rngAnchor.Top
.Left = rngAnchor.Left
With .ShapeRange
.LockAspectRatio = msoTrue
If .Width >= .Height Then
.Width = maxWidth
Else
.Height = maxHeight
End If
End With
End With
End Sub

'
End Sub

Beliebteste Forumthreads (12 Monate)

Bild einfügen mit autom. Größenanpassung

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild einfügen mit autom. Größenanpassung

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread