Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1016to1020
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Hyperlink setzen
22.10.2008 13:43:51
Snewi
Hallo,
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ß

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Hyperlink setzen
22.10.2008 15:09:36
rofu
'############################################################################################'
' Die folgenden Makros" BILDER " durchsuchen einen Ordner und seine Unterordner '
'############################################################################################'
'Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.'
Public Type BROWSEINFO '
hOwner As Long '
pidlRoot As Long '
pszDisplayName As String '
lpszTitle As String '
ulFlags As Long '
lpfn As Long '
lParam As Long '
iImage As Long '
End Type '
Declare

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

Anzeige
AW: Hyperlink setzen
23.10.2008 08:25:41
Snewi
macht das Makro das was ich wollte?
Also über einen Button "Bild einlesen" den Link in eine Zelle schreiben oder ein kleines Vorschabild anzeigen was bei Doppelklick geöffnet wird? Oder geht es auch einfacher als oben?
P.S. Es wird ein Fehler ausgegeben "erwartetes Anweisungsende"
Function SHGetPathFromIDList "LIB" "SHELL32.DLL" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Gruß
AW: Hyperlink setzen
23.10.2008 09:23:00
Snewi
Ich will ja nur:
Range("C13").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"Pfad", TextToDisplay:= _
"Bild"
das ich ein Verzeichnis bekomme um das Bild auszuwählen und dann den Hyperlink in die Zelle zu schreiben!
Gruß
P.S. Wäre auch ein kleines Vorschaubild möglich?
Anzeige
AW: Hyperlink setzen
24.10.2008 08:34:00
Snewi
Hallo,
das sieht schon echt gut aus aber wie kann ich nun ein Bild einzeln einlesen! Ich hab also mehrere Zeilen und nun möchte ich nur in eine Zeile jeweils ein Bild zuordnen nur mit dem Link ohne Vorschaubild das wird sonst zu Groß!
Danke
Gruß
AW: Hyperlink setzen
26.10.2008 13:03:16
rofu
Hallo Snewi,
vielleicht ist es das.
https://www.herber.de/bbs/user/56288.xls
bin gespannt !
gruß
rofu
Anzeige
AW: Hyperlink setzen
26.10.2008 20:24:54
Snewi
Hallo,
sieht schon richtig gemial aus! Geht es das anstatt von Bild der Pfad und der Name des Bildes angezeigt wird?
Und ich fänd es gut das diese Sicherheitsmeldung wegen Hyperlinks nicht erscheint!
Danke im voraus!
Gruß
AW: Hyperlink setzen
27.10.2008 07:10:00
rofu
https://www.herber.de/bbs/user/56310.xls
Hallo,
jetzt wird der Pfad angezeigt, Bild war nur als hinweis gedacht.
Fehlermeldung kommt bei mir keine - welche kommt bei dir?
Gruß
rofu
AW: Hyperlink setzen
27.10.2008 08:31:00
Snewi
Es klappt nun Danke Super :-)

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige