Anpassung Bild code vom Josef Ehrensberger
Karel
Ich habe im Forum unterstehende schöne Code gefunden.
https://www.herber.de/forum/archiv/1104to1108/t1107770.htm
Kan het makro so angepasst worden, das wenn im Zelle B1 Pfadname steht und bildname in spalte C ab C3 stehen.
Also bildname in Spalte C
Pfadname im B1
Bilder im Spalte B einlesen anhand Dateiname Spalte C
Code vom Josef Ehrensberger
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importPictures()
Dim objShp As Shape
Dim strPath As String
Dim objFiles() As Object
Dim lngRes As Long, lngIndex As Long
strPath = fncBrowseForFolder
ActiveSheet.Shapes.SelectAll
Selection.Delete
If strPath "" Then
lngRes = FileSearchINFO(objFiles, strPath, "*.jpg;*.gif", False)
If lngRes > 0 Then
For lngIndex = 0 To UBound(objFiles)
ActiveSheet.Pictures.Insert (objFiles(lngIndex))
Set objShp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
Rows(lngIndex + 4).RowHeight = 141.75
With objShp
.Left = Columns(2).Left
.Top = Cells(lngIndex + 4, 2).Top
.LockAspectRatio = msoFalse
.Height = 141.75
.Width = 141.75
.AlternativeText = "small"
.OnAction = "resizePic"
End With
Next
End If
End If
End Sub
Sub resizePic()
Dim objShp As Shape
Set objShp = ActiveSheet.Shapes(Application.Caller)
With objShp
If .AlternativeText = "small" Then
.AlternativeText = ""
.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
.ZOrder msoBringToFront
Else
.LockAspectRatio = msoFalse
.Height = 141.75
.Width = 141.75
.AlternativeText = "small"
End If
End With
Set objShp = Nothing
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*. _
*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
GrüßeKarel