wie kann ich über eine Forms ein Bild aus einem Ordner hochladen und dann den Pfad als Hyperlink in eine Zelle schreiben? Wenn ich dann den Link anklicke soll in einem extra Fenster das Bild zu sehen sein!
Ist das in VBA möglich?
Gruß
Function SHGetPathFromIDList Lib "SHELL32.DLL" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "SHELL32.DLL" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Msg) As String
Dim myInfo As BROWSEINFO
Dim myPath As String
Dim Root As Long, ID As Long, pos As Integer
With myInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
ID = SHBrowseForFolder(myInfo)
myPath = Space$(512)
Root = SHGetPathFromIDList(ByVal ID, ByVal myPath)
If Root Then
pos = InStr(myPath, Chr$(0))
GetDirectory = Left(myPath, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub BILDER()
Dim ordner As String
Dim oBilder As Worksheet
Dim FS As FileSearch
Dim sName As String
Application.ScreenUpdating = False
'VEREINBARUNGEN:
'Name des Bildauswahlblattes
sName = "Bildauswahl"
'Name des Orners
Dim Msg As String, myPath As String
Msg = "Wähle ein Verzeichnis aus," & Chr(13) & "aus dem Bilder angezeigt werden sollen:"
myPath = GetDirectory(Msg)
If myPath = "" Then
Exit Sub
Else
ordner = myPath
Set FS = Application.FileSearch
With FS
.NewSearch
.LookIn = ordner
.SearchSubFolders = False
.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 " & ordner
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 = 4
For i = 1 To FS.FoundFiles.Count
'Vereinbarung der Typen, die gesucht werden können
If FS.FoundFiles(i) Like "*.jpg" Or _
FS.FoundFiles(i) Like "*.JPG" Or _
FS.FoundFiles(i) Like "*.tif" Or _
FS.FoundFiles(i) Like "*.TIF" Or _
FS.FoundFiles(i) Like "*.gif" Or _
FS.FoundFiles(i) Like "*.GIF" Or _
FS.FoundFiles(i) Like "*.png" Or _
FS.FoundFiles(i) Like "*.PNG" Or _
FS.FoundFiles(i) Like "*.jp2" Or _
FS.FoundFiles(i) Like "*.JP2" Or _
FS.FoundFiles(i) Like "*.ico" Or _
FS.FoundFiles(i) Like "*.ICO" Or _
FS.FoundFiles(i) Like "*.emf" Or _
FS.FoundFiles(i) Like "*.EMF" Or _
FS.FoundFiles(i) Like "*.bmp" Or _
FS.FoundFiles(i) Like "*.BMP" Then
'Festsetzung von Bild- und Zeilenhöhe
oBilder.Rows(iZeile).RowHeight = 50
'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 = 50
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
Application.ScreenUpdating = True
Exit Sub
fehler:
If Err.Number = 1004 Then sName = sName & "_X": Resume
End If
End Sub
LG
rofu