AW: Bilder in Excel Tabelle als Link ?
08.07.2003 15:46:39
ivan
hi
du brauchst 3 module und einen commandbutton in der tabelle.
in modul 1
Sub bilddateien_lesen()
Application.ScreenUpdating = False
Dim strInitialDir As String, strPath As String
Dim sFile As String, sPattern As String, sPath As String
Dim iRow As Integer
Columns(1).ClearContents
sPath = BrowseDirectory()
If sPath = "" Then Exit Sub
'einlesen
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sPattern = "*.*"
Dim ordner As String
Dim oBilder As Worksheet
Dim FS As FileSearch
Dim sName As String
'Name des Bildauswahlblattes
sName = "Ohne Namen"
'ORDNER DURCHSUCHEN
'FileSearch definieren
Set FS = Application.FileSearch
With FS
.NewSearch
.LookIn = sPath
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
.Execute
End With
'BLATT ERSTELLEN UND EINRICHTEN
On Error GoTo fehler
Set oBilder = Worksheets.Add
oBilder.Name = sName
'Blattkopf
oBilder.Cells(1, 1).Value = "Bilder aus " & sPath
oBilder.Cells(2, 1).Value = "Vorschau"
oBilder.Cells(2, 2).Value = "Link"
With oBilder.Cells(1, 1).Font
.Bold = True
.Size = .Size + 4
End With
With oBilder.Range(Cells(2, 1), Cells(2, 2)).Font
.Bold = True
.Size = .Size + 2
End With
'DATEIEN AUS ORDNER EINLESEN
On Error GoTo 0
Dim iZeile As Integer
iZeile = 3
For i = 1 To FS.FoundFiles.Count
'Vereinbarung der Typen, die gesucht werden können
If FS.FoundFiles(i) Like "*.*" Then
'Festsetzung von Bild- und Zeilenhöhe
oBilder.Rows(iZeile).RowHeight = 150
'Text vertikal mittig in Zeile
oBilder.Rows(iZeile).VerticalAlignment = xlVAlignCenter
'gefundenes Bild einfügen und Höhe auf Zeilenhöhe setzen
oBilder.Cells(iZeile, 1).Select
ActiveSheet.Pictures.Insert(FS.FoundFiles(i)).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Height = 150
oBilder.Hyperlinks.Add Anchor:=.Item(1), Address:=FS.FoundFiles(i)
End With
'maximale Breite merken
If Selection.ShapeRange.Width > maxWidth Then _
maxWidth = Selection.ShapeRange.Width
'Hyperlink mit Dateinamen in Spalte B
oBilder.Hyperlinks.Add Anchor:=oBilder.Cells(iZeile, 2), _
Address:=FS.FoundFiles(i), _
TextToDisplay:=FS.FoundFiles(i), _
ScreenTip:="Hier klicken, um das Bild anzuzeigen ..."
'Zeilenzähler hochsetzen
iZeile = iZeile + 2
End If
Next
'Breite der 1. Spalte auf max. Breite, der 2. Spalte auf optimale Breite
maxWidth = maxWidth * oBilder.Columns(1).ColumnWidth / _
oBilder.Columns(1).Width + 5
If maxWidth > 255 Then maxWidth = 255
oBilder.Columns(1).ColumnWidth = maxWidth
oBilder.Columns(2).AutoFit
oBilder.Cells(3, 1).Select
Exit Sub
fehler:
If Err.Number = 1004 Then sName = sName & "_": Resume
Application.ScreenUpdating = True
End Sub
modul 2
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" _
(ByVal szPath As String) As Long
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const BFFM_INITIALIZED As Long = 1
Private Const MAX_PATH As Long = 260
Private Const WM_USER As Long = &H400
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Private Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
' Callback für die Browse-Directory-Methode - "pidList"-Methode
' zur Verwendung in der BrowseDirectory()-Funktion
Private Function BrowseCallBackProc(ByVal hwnd As Long, _
ByVal uMsg As Long, ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Voreinstellung des Verzeichnisses im Verzeichnis-
'Dialog unter Verwendung des Parameters "pidList"
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTIONA, False, ByVal lpData)
Case Else
End Select
End Function
Private Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function
Private Function GetPIDLFromPath(ByVal sPath As String) As Long
GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
End Function
Public Function BrowseDirectory(Optional ByVal strInitialDir As String, Optional ByVal _
hwnd As Long) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BROWSEINFO
szTitle = "Please select a directory"
With tBrowseInfo
.hwndOwner = hwnd
.pidlRoot = 0
.lpszTitle = szTitle
.lpfnCallback = FARPROC(AddressOf BrowseCallBackProc)
.lParam = GetPIDLFromPath(strInitialDir)
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseDirectory = sBuffer
CoTaskMemFree lpIDList
Else
BrowseDirectory = strInitialDir
End If
' Ressourcen freigeben
CoTaskMemFree tBrowseInfo.lParam
End Function
Sub OrdnerAuswahl()
Dim strInitialDir As String, strPath As String
strPath = BrowseDirectory()
End Sub
modul 3
Option Explicit
' für Versionen unter XP
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Private Function GetAOrdner() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
'.hwnd = FindWindow("", "Auswahl") ' Userform Auswahl
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim(FolderName)
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
GetAOrdner = FolderName
End Function
' *****
Sub LFD_Einzeln_Sammeln_Gesamt()
'LEISTEN AUSBLENDEN
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
Application.CommandBars("Standard").Visible = False
Application.CommandBars("Formatting").Visible = False
Application.CommandBars("Visual Basic").Visible = False
Application.CommandBars("Drawing").Visible = False
End With
With Application
.DisplayFormulaBar = False
.DisplayStatusBar = False
End With
Dim InI As Integer
Dim strDatei As String
Dim strVerzeichnis As String
Dim pct As Picture
' löscht alle Bilder auf dem aktuellen Blatt,
' wenn deren erste drei Buchstaben "Pic" sind
For InI = ActiveSheet.Shapes.Count To 1 Step -1
If Left(ActiveSheet.Shapes(InI).Name, 3) = "Pic" Then ActiveSheet.Shapes(InI).Delete
Next
Range("A1") = ""
'strVerzeichnis = "D:\Eigene Dateien\Eigene Bilder\Bilder\Sammeln"
'strVerzeichnis = "D:\Eigene Dateien\Eigene Bilder\Bilder\0001-1000"
' Versionen unter XP
' strVerzeichnis = GetAOrdner
' ******
'Ab XL2002 / Xp:
'von Frank Arendt-Theilen (NG)
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
strVerzeichnis = fd.SelectedItems(1)
Else
Exit Sub
End If
' *****
strDatei = Dir(strVerzeichnis & "\*.*")
Cells(2, 1).Select
Do While strDatei <> ""
If strDatei = "" Then Exit Do
Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei)
ActiveSheet.Shapes(pct.Name).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 350
'Selection.ShapeRange.Width = 400
Calculate ' damit Bildgröße angepast wird
Cells(1, 1) = strDatei
Application.Wait Now + TimeSerial(0, 0, 6)
ActiveSheet.Shapes(pct.Name).Delete
strDatei = Dir()
Loop
End Sub
und zu guter letzt der commandbutton der das ganze startet(in der tabelle)
Private Sub CommandButton1_Click()
Call LFD_Einzeln_Sammeln_Gesamt
End Sub
IVAN