Namen einer Datei auslesen und in Zellen scheriben
03.03.2005 08:24:58
Brit
Nachfolgend kommt nun ein Code, der folgendes erfüllen soll:
Ich möchte eine große Anzahl an Grafikdateien nacheinander in die erste Zelle einer Zeile schreiben, die Zeile der Höhe des Bildes anpassen.
Das klappt auch schon wunderbar.
Nun möchte ich noch den Name der Grafikdatei auslesen und in die Zelle daneben schreiben. Aber nur den eigentlichen Name und nicht das Dateianhängsel!
Also bei Name.xyz soll ".xyz" wegfallen!
Kann mir da jemand helfen und meinen Fehler suchen! Zur Zeit kann er den Namen noch gar nicht auslesen.
Vielen Dank schon mal im Voraus
Brit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sFiles As String
If Target.Column > 1 Then
Exit Sub
End If
Dim ZuOeffnendeDatei
Dim isGrafik As Boolean, i As Long
On Error Resume Next
ZuOeffnendeDatei = Application.GetOpenFilename( , , "Grafikdateien", , True)
Range("A1").Activate
With Sheets("Tabelle2")
For i = 1 To UBound(ZuOeffnendeDatei)
isGrafik = True
Select Case LCase(Right$(ZuOeffnendeDatei(i), 3))
Case "jpg"
Case "gif"
Case "bmp"
Case Else
End Select
Dim zahl
zahl = Len(ZuOeffnendeDatei(i).name) - Right$(ZuOeffnendeDatei(i).name,3)
Dim name
name = Left(ZuOeffnendeDatei(i).name, zahl)
If isGrafik Then
.Pictures.Insert ZuOeffnendeDatei(i)
dHeight = ActiveSheet.Pictures.Height
ActiveCell.Rows.RowHeight = dHeight
ActiveCell.Offset(0, 1).Value = name
ActiveCell.Offset(1, 0).Activate
End If
Next
End With
End Sub