PDA

Vollständige Version anzeigen : pfad aus mehreren zellen lesen und objekt nebenan uebergeben


michael96
24.08.2012, 14:38
Hallo,

ich habe einen zusammengestellten code aus dem forum umgeschrieben damit er meinen beduerfnissen entsprechend arbeitet. Ich moechte dass man einen pfad in mehrere zellen eingeben kann und daneben dann die bilder angezeigt werden. Leider bekomme ich aber keine fehlermeldung und weiss nicht so recht was an meinem code nicht stimmt.

Private Sub PictureViewer()
On Error Resume Next
Dim i As Long
Dim Picture As Object
Dim Path As String
Dim ii As Long
Dim verz As String
Range("$B$3").Select 'hier wird der Ordnerpfad eingegeben
verz = Selection
ChDir verz 'wechselt das Verzeichnis aus Zelle B3
Rows(5).ClearContents 'Löscht die Daten, jedoch nicht die Formatierung.
Range("B5").Select 'Erste Zelle die später befüllt wird
With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = False 'Unterordner werdenn nicht durchsucht
.FileType = msoFileTypeAllFiles
.Execute
For i = 1 To .FoundFiles.Count
ActiveCell.Value = .FoundFiles(i) 'schreibt Pfad+Bildname in Zelle
ActiveCell.Offset(0, 1).Select

'springt zur naechsten Zelle und schreibt naechsten Pfad+Bildname in Zelle

Next i
Range("C1").Value = i - 1 & " pictures in file"

'gibt an wie viele Bilder im Ordner gefunden wurden

End With
End Sub


Diesen Code habe ich in nachfolgenden umgewandelt und muss wohl einen fehler drin haben. es kommt aber keine fehlermeldung.

Private Sub ShowPictures()
On Error Resume Next
Dim i As Long
Dim Picture As Object
Dim Path As String
Dim ii As Long
Dim verz As String
For iii = 21 To 30 'soll Bilder anzeigen fuer Pfade in B21 bis B30
If Cells(iii, 2) = "" Then 'falls Pfad nicht angegeben Anwendung beenden
Exit Sub
End If
Cells(iii, 2).Select 'hier wird der Ordnerpfad entnommen
verz = Selection
ChDir verz 'wechselt das Verzeichnis aus Zelle
Range("C21").Select 'Erste Zelle die später befüllt wird
With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = False 'Unterordner werden nicht durchsucht
.FileType = msoFileTypeAllFiles
.Execute
For i = 1 To .FoundFiles.Count
ActiveCell.Value = .FoundFiles(i) 'schreibt Pfad+Bildname in Zelle
ActiveCell.Offset(0, 1).Select

'springt zur naechsten Zelle und schreibt naechsten Pfad+Bildname in Zelle

Next i

Range("C1").Value = i - 1 & " pictures in file" 'gibt an wie viele Bilder im Ordner gefunden wurden

End With
Next iii
End Sub

Kann mir jemand damit helfen

Hajo_Zi
24.08.2012, 15:08
Hallo michael,

könnte es daran liegen das bei Deiner Version 2010 den Befehl Application.FileSearch
nicht mehr gibt?

<img src="http://Hajo-Excel.de/images/grusz1.gif" align="middle" height="40" alt="Grußformel"><a href="http://Hajo-Excel.de/index.htm" onclick="window.open(this.href);return false"><img border="0" src="http://Hajo-Excel.de/images/logo_hajo3.gif" align="middle" height="40" alt="Homepage"></a>

michael96
27.08.2012, 16:32
Halo Hajo,

danke fuer Deine Antwort. Daran liegt es nicht, weil ich jetzt auf excel 2003 arbeite. Ich habe den code aber umgeaendert und er funktioniert jetzt auch wenn es sicher nicht die beste Art is.

Private Sub ShowPictures()
On Error Resume Next

Dim i As Long 'Zähler, um aus Datei Pfad für jedes Bild zu erfassen
Dim Picture As Object
Dim Path As String
Dim j As Long 'j Spalten (von FP) bis Anzahl Bilder
Dim verz As String
Dim k As Long 'k gibt die Zeile an die beschrieben wird

Rows("4:2000").Select
Selection.RowHeight = 45 'legt die Höhe der Zeilen fest (damit Bilder sich nicht überlappen)

For k = 4 To 14 'soll Bilder anzeigen fuer Pfade in FO4 bis FO50
Cells(k, 171).Select 'hier wird der Ordnerpfad entnommen, ab Zelle FO4 in Spalte FO
verz = Selection
ChDir verz 'wechselt das Verzeichnis aus Zelle
Cells(k, 172).Select 'erste Zelle die später befüllt wird, 172 steht hier für Spalte FP

With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = False 'Unterordner werdenn nicht durchsucht
.FileType = msoFileTypeAllFiles
.Execute
For i = 1 To .FoundFiles.Count
ActiveCell.Value = .FoundFiles(i) 'schreibt Pfad+Bildname in Zelle
ActiveCell.Offset(0, 1).Select 'springt zur naechsten Zelle und schreibt naechsten Pfad+Bildname in Zelle

Next i
End With
Application.ScreenUpdating = False 'ab hier werden die Bilder angezeigt
For j = 172 To Cells(k, Columns.Count).End(xlUp).Column
Path = Cells(k, j).Value
Set Picture = ActiveSheet.Pictures.Insert(Path)
With Picture
.Left = Cells(k, j).Left
.Top = Cells(k, j).Top
If .ShapeRange.Width > .ShapeRange.Height Then
.ShapeRange.Width = 50 'legt fest wie Breit die angezeigten Bilder sein sollen
Else
.ShapeRange.Height = 50 'legt fest wie Hoch die angezeigten Bilder sein sollen
End If
End With
Set Picture = Nothing
Next j
Application.ScreenUpdating = True
Call prcReset 'started das Modul1 in dem die Bilder dann vergrössert und verkleinert werden
Range("FP4:IV50").ClearContents 'löscht Pfad aus Zellen, Bilder bleiben bestehen
Next k
End Sub

Wie gesagt der Code macht jetzt was ich beabsichtigt habe, aber durchlaeuft er immer alle Zellen mit Pfadeingabe und erstellt alle Bilder neu. Kann man das aendern und nur eine 'aktuelle' Zelle bearbeiten lassen? Also irgendwie mit ActiveCell usw??

Lg,
Michael