Hyperlink erstellen über Dialog

Hallo zusammen,
bestimmt kann mir jemand von Euch bei einem kleinen Problem in die Schuhe helfen.
Ich habe eine zentrale Excel-Liste, in der Artikel mit Zeichnungsnummern gepflegt werden.
In dieser Liste soll auch der Pfad der Zeichnungsdatei stehen.
Diese Zelle mit Pfad sollte gleich mit dem Zielordner verlinkt sein, so dass sich der Explorer nach dem Anklicken der Zelle im entspr. Pfad öffnet.
Diese Eingaben können verschiedene User machen.
Einige MA haben aber mit dem Erstellen von Hyperlinks Probleme.
Deshalb habe ich mir gedacht, es wäre gut, wenn ich den Zielordner für den HLink in der aktuellen Zelle über einen Dialog wie bei 'speichern unter' auswählen könnte.
Kann mich da jemand unterstützen ? =-)
Gruß
Andreas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Andreas!
Eine Möglichkeit.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function GetActiveWindow Lib "user32" () As Long

Sub LinkZumOrdner()
Dim strPath As String, strMsg As String, strText As String
Dim bMod As Boolean
Dim vBase As Variant
Dim lngResult As Long, lngCntrl As Long

strMsg = "Wählen Sie einen Ordner aus:"
lngCntrl = 1
vBase = "C:\Eigene Dateien"

bMod = True 'True oder False

lngResult = OrdnerAuswaehlen(bMod, strMsg, lngCntrl, vBase, strPath)
If lngResult = 0 Then
  If ActiveCell.Text = "" Then
    strText = InputBox("Link anzeigen als:", "Link", "Link")
  End If
  ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=strPath, TextToDisplay:=strText
End If

End Sub

Private Function OrdnerAuswaehlen(ByVal bMod As Boolean, _
  ByVal strMsg As String, _
  ByVal lngCntrl As Long, _
  ByVal vBase As Variant, strPath As String) As Long

Dim Owner As Long, oFolder As Object, oShell As Object
Dim rc As Long, sysmsg As String
If bMod Then Owner = GetActiveWindow

On Error Resume Next
Set oShell = CreateObject("Shell.Application")
rc = Err.Number: sysmsg = Err.Description: Err.Clear
If rc = 0 Then
  Set oFolder = oShell.BrowseForFolder(Owner, strMsg, lngCntrl, vBase)
  rc = Err.Number: sysmsg = Err.Description
End If
On Error GoTo 0
If oFolder Is Nothing Then
  OrdnerAuswaehlen = 4
Else
  strPath = oFolder.Self.Path
  If Right(strPath, 1) = "\" Then strPath = Left(strPath, Len(strPath) - 1) 'Normalisieren
End If
If Not rc = 0 Then
  MsgBox "Laufzeitfehler: " & rc & vbLf & sysmsg, vbExclamation
  OrdnerAuswaehlen = 16
End If
Set oFolder = Nothing
Set oShell = Nothing
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread