Excel | VBA | Bilder aus Ordner gezielt einfügen u

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Excel | VBA | Bilder aus Ordner gezielt einfügen u
von: Harald
Geschrieben am: 06.10.2015 10:53:39

Hallo!
Ich bin auf der Suche nach einem Excel Makro/VBA welches folgende Funktion beherbergt:
Per Button, werden neben der aktuell markierten Zelle alle JPGs aus einem bestimmten Ordner in die rechts daneben liegenden Spalten/Zellen importiert
Die importierten JPGs sollen in Excel auf eine gewisse Darstellungsgröße in px verkleinert werden (Urbild sollte jedoch noch vorhanden sein)
Die importierten JPGs werden nach Import aus dem Ordner gelöscht
Könnt Ihr mir hierbei helfen? Meine VBA Kenntnisse sind sehr bescheiden....
Danke
Harry

Bild

Betrifft: AW: Excel | VBA | Bilder aus Ordner gezielt einfügen u
von: Sepp
Geschrieben am: 06.10.2015 21:19:23
Hallo Harald,
weise "insertPictures" einer Schaltfläche zu.
Beim Klick auf ein Bild, wird es in Originalgröße angezeigt, bei einem weiteren Klick, wird es wieder verkleinert.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Const cWidth As Long = 45 'Bildbreite in Pixel

Sub insertPictures()
Dim strPath As String, strFile As String
Dim rng As Range, lngOffset As Long
Dim objPic As Picture

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\"
  .Title = "Bilder einfügen - Ordnerauswahl"
  .ButtonName = "Auswahl..."
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  Set rng = ActiveCell
  strFile = Dir(strPath & "*.jpg", vbNormal)
  Do While strFile <> ""
    lngOffset = lngOffset + 1
    Set objPic = ActiveSheet.Pictures.Insert(strPath & strFile)
    With objPic
      .Top = rng.Top
      .Left = rng.Offset(0, lngOffset).Left
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = cWidth
        .AlternativeText = 0
      End With
      .OnAction = "ToggleSize"
    End With
    strFile = Dir
  Loop
  'JPG's löschen
  Kill strPath & "*.jpg"
End If

Set objPic = Nothing
Set rng = Nothing
End Sub


Private Sub ToggleSize()
Dim objPic As Picture

Set objPic = ActiveSheet.Pictures(Application.Caller)

With objPic.ShapeRange
  If .AlternativeText = "0" Then
    .AlternativeText = 1
    .ScaleWidth 1, msoTrue, msoScaleFromTopLeft
    .ZOrder 0
  Else
    .AlternativeText = 0
    .Width = cWidth
  End If
End With

Set objPic = Nothing
End Sub

Gruß Sepp


Bild

Betrifft: AW: Excel | VBA | Bilder aus Ordner gezielt einfügen u
von: Harald
Geschrieben am: 07.10.2015 07:15:22
wahnsinn - vielen lieben dank für das tolle programm!
bin gerade am testen - funktioniert soweit super, jedoch werden die importierten
JPGs nicht direkt im XLS File gesichert, sondern verlinken sich nur auf den JPG-Ordner.
Werden die JPGs zum Schluss aus dem Ordner gelöscht und öffnet man das XLS File neu, so sind
die Bilder im XLS File allesamt weg (da Verknüpfung weg)... könntest Du hierbei helfen?
Vielen Dank!!!
Harry

Bild

Betrifft: AW: Excel | VBA | Bilder aus Ordner gezielt einfügen u
von: Sepp
Geschrieben am: 07.10.2015 18:57:07
Hallo Harry,
dann so. Hab den Code noch etwas "verfeinert"

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'Code aus "Online Excel Forum" - http://www.online-excel.de/
'Postet by Nepumuk, 20/06/05
'Geändert von J.Ehrensberger 08/02/06
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" (ByVal lpDriverName As String, _
  ByVal lpDeviceName As String, ByVal lpOutput As String, ByRef lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As _
  Long
Private Declare Function MulDiv Lib "Kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, _
  ByVal nDenominator As Long) As Long

Private Const LOGPIXELSX = 88&
Private Const LOGPIXELSY = 90&
Private Const HimetricInch = 2540&


'### Einstellungen ###

Private Const cWidth As Long = 60 'Bildbreite in Pixel
Private Const cGap As Long = 3 'Abstand zwischen den Bildern in Pixel bei Fixabstand
Private Const cFixedGap As Boolean = False 'Fixer Abstand zwischen den Bildern


Sub insertPictures()
Dim strPath As String, strFile As String
Dim rng As Range, lngOffset As Long
Dim objPic As Shape
Dim sngWidth As Single, sngGap As Single
Dim dblW As Double, dblH As Double

sngWidth = cWidth * 0.75
sngGap = cGap * 0.75

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\"
  .Title = "Bilder einfügen - Ordnerauswahl"
  .ButtonName = "Auswahl..."
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  Set rng = ActiveCell
  strFile = Dir(strPath & "*.jpg", vbNormal)
  Do While strFile <> ""
    lngOffset = lngOffset + 1
    GetImageSize strPath & strFile, dblW, dblH
    Set objPic = ActiveSheet.Shapes.AddPicture(strPath & strFile, msoFalse, msoTrue, 0, 0, dblW, dblH)
    With objPic
      .Top = rng.Top
      If cFixedGap Then
        .Left = rng.Offset(0, 1).Left + (sngWidth * (lngOffset - 1)) + _
          (sngGap * -(lngOffset > 1)) * (lngOffset - 1)
      Else
        .Left = rng.Offset(0, lngOffset).Left
      End If
      .LockAspectRatio = True
      .Width = sngWidth
      .AlternativeText = 0
      .Shadow.Style = msoShadowStyleOuterShadow
      .Shadow.Visible = msoFalse
      .Line.Style = msoLineSingle
      .Line.Visible = msoFalse
      .OnAction = "ToggleSize"
    End With
    strFile = Dir
  Loop
  'JPG's löschen
  If MsgBox("Importierte Bilder von der Festplatte löschen?", 292) = vbYes Then
    Kill strPath & "*.jpg"
  End If
End If

Set objPic = Nothing
Set rng = Nothing
End Sub


Private Sub ToggleSize()
Dim objPic As Picture

Set objPic = ActiveSheet.Pictures(Application.Caller)

With objPic.ShapeRange
  If .AlternativeText = "0" Then
    .AlternativeText = 1
    .ScaleWidth 1, msoTrue, msoScaleFromTopLeft
    .Shadow.Visible = msoTrue
    .Line.Visible = msoTrue
    .ZOrder 0
  Else
    .AlternativeText = 0
    .Width = cWidth * 0.75
    .Shadow.Visible = msoFalse
    .Line.Visible = msoFalse
    .ZOrder 1
  End If
End With

Set objPic = Nothing
End Sub

Private Function GetImageSize(ByVal strPicturePath As String, ByRef dblWidth As Double, ByRef dblHeight As Double) As Long
Dim MyPicture As StdPicture
On Error GoTo ErrExit
Set MyPicture = LoadPicture(strPicturePath)
If Not MyPicture Is Nothing Then
  GetImageSize = -1
  dblWidth = HimetricToPixelsX(MyPicture.Width)
  dblHeight = HimetricToPixelsY(MyPicture.Height)
End If
ErrExit:
Err.Clear
On Error GoTo 0
Set MyPicture = Nothing
End Function

Private Function HimetricToPixelsX(ByVal inHimetric As Long) As Long
HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)
End Function

Private Function HimetricToPixelsY(ByVal inHimetric As Long) As Long
HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)
End Function

Private Function ConvertPixelHimetric(ByVal inValue As Long, _
  ByVal ToPix As Boolean, inXAxis As Boolean) As Long

Dim TempIC As Long, GDCFlag As Long
TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
If (TempIC) Then
  If (inXAxis) Then GDCFlag = LOGPIXELSX Else GDCFlag = LOGPIXELSY
  If (ToPix) Then ConvertPixelHimetric = MulDiv(inValue, _
    GetDeviceCaps(TempIC, GDCFlag), HimetricInch) _
  Else ConvertPixelHimetric = MulDiv(inValue, _
    HimetricInch, GetDeviceCaps(TempIC, GDCFlag))
  Call DeleteDC(TempIC)
End If
End Function

Gruß Sepp


Bild

Betrifft: AW: Excel | VBA | Bilder aus Ordner gezielt einfügen u
von: Harald
Geschrieben am: 08.10.2015 15:02:35
wahnsinn - vielen dank! funktioniert perfekt! glg

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Excel | VBA | Bilder aus Ordner gezielt einfügen u"