AW: Bilder in eine Zelle einfügen
kdosi
Hallo Oliver,
mit diesem Code kann man die jpg-Bilder aus einem bestimmten Ordner einlesen und in die Excel Datei einfuegen. Du musst aber die Konstanten wie ORDNER usw. neu einstellen. COL_MAX sagt, wieviel Spalten man benutzen will (maximum ist 256 :-)). Die Bilder werden der Groesse der Zellen angepasst. Ich habe es mit einem Ordner, der cca 20 dateien hatte getestet, die Dateien waren klein, es hat gut geklappt. Dann habe ich es mit einem Ordner getestet, der cca 50 Dateien hatte, die Dateien waren groessere Bilder und es hat sehr lange gedauert, Memory war nicht genug. Also falls Du den Code testen willst, solltest Du darauf denken. Ich habe aber nur 128 MB RAM, Pentium III mit 500 MHz :-)
Gruss kdosi, CZ
Option Explicit
Public Const ORDNER = "C:\Bilder"
Public Const FILTER As String = "jpg"
Public Const ROW_START As Long = 3
Public Const COL_START As Integer = 2
Public Const COL_MAX As Integer = 5
Public
Sub Main()
On Error GoTo Err_In_Test
Dim zeile As Long, spalte As Integer, fehlerhaft As String
Dim fso As Object
Dim fld As Object
Dim fi As Object
Application.ScreenUpdating = False
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(ORDNER)
fehlerhaft = ""
zeile = ROW_START
spalte = COL_START
For Each fi In fld.Files
If (VBA.UCase(VBA.Right(fi.Name, 3)) = VBA.UCase(FILTER)) Then
Cells(zeile, spalte).Activate
If (InsertPicture(ActiveCell, fi.Path) = False) Then
fehlerhaft = fehlerhaft & fi.Name & VBA.Constants.vbCrLf
Else
If (spalte = COL_MAX) Then
zeile = zeile + 1
spalte = COL_START
Else
spalte = spalte + 1
End If
End If
End If
Next fi
If (fehlerhaft <> "") Then VBA.MsgBox "Fehlerhaften Bilder : " & VBA.Constants.vbCrLf & _
fehlerhaft, vbExclamation, "fehlerhaft"
Application.ScreenUpdating = True
Exit Sub
Err_In_Test:
MsgBox "Error " & Err.Number, vbCritical, "severe"
End Sub
Public
Function InsertPicture(ByVal zelle As Range, ByVal pfad As String) As Boolean
On Error GoTo Err_In_InsertPicture
InsertPicture = False
Dim ole_picture As OLEObject
Set ole_picture = zelle.Parent.OLEObjects.Add(ClassType:="Forms.Image.1")
With ole_picture.Object
.Picture = LoadPicture(pfad)
.AutoSize = False
End With
With ole_picture
.Placement = xlFreeFloating
.Top = zelle.Top
.Left = zelle.Left
.Height = zelle.Height
.Width = zelle.Width
End With
InsertPicture = True
Set ole_picture = Nothing
Exit Function
Err_In_InsertPicture:
End Function