Excel VBA: Hyperlink mit Servername und nicht mit Laufwerksbuchstabe

Question

Hallo zusammen,

gibt es eine Möglichkeit, den Pfad einer Datei bzw. eines Ordners direkt mit dem Servernamen auszulesen und nicht nur mit dem Laufwerksbuchstaben?

d.h. ich ich bekomme den Pfad nicht als
Y:\Test\
sondern als
\\Servername\Test\

Aktuell umgehe ich das Problem, indem ich einen Hyperlink einfüge (der enthält dann gleich den Servernamen) und diesen wieder auslese, wie in diesem kleinen Beispiel:

Public Sub HyperlinkUmwandeln()
 
Dim oWB As Workbook
Dim oWS As Worksheet
Dim strHyperlinkAdresse As String
 
Set oWB = ThisWorkbook
Set oWS = oWB.ActiveSheet
 
strHyperlinkAdresse = oWB.Path
 
'ggf.Hyperlink löschen
If oWS.Cells(1, 1).Hyperlinks.Count > 0 Then oWS.Cells(1, 1).Hyperlinks.Delete
 
' Hyperlink einfügen (mit Laufwerksbuchstaben)
oWS.Hyperlinks.Add Anchor:=oWS.Cells(1, 1), Address:=strHyperlinkAdresse
 
' Adresse des Hyperlinks wieder auslesen (hier bekommt man den Long UNC Code - Pfad)
strHyperlinkAdresse = oWS.Cells(1, 1).Hyperlinks(1).Address
 
'ggf.Hyperlink löschen
If oWS.Cells(1, 1).Hyperlinks.Count > 0 Then oWS.Cells(1, 1).Hyperlinks.Delete
 
' Hyperlink einfügen (mit Serveradresse)
oWS.Hyperlinks.Add Anchor:=oWS.Cells(1, 1), Address:=strHyperlinkAdresse
 
End Sub

Im voraus vielen Dank!

Gruß
Jürgen

Answer 1

hi all :-)

vielleicht hilfreich :-)

von einem anderen netten user ^^

gruss nighty

Option Explicit
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long
Const DRIVE_UNKNOWN = 0
Const DRIVE_NOT_FOUND = 1
Const DRIVE_REMOVABLE = 2
Const DRIVE_FIXED = 3
Const DRIVE_REMOTE = 4
Const DRIVE_CDROM = 5
Const DRIVE_RAMDISK = 6
Const WN_NO_ERROR = 0
Const WN_BAD_DEVICE = 1200&
Const WN_CONNECTION_UNAVAILABLE = 1201&
Const WN_EXTENDED_ERROR = 1208&
Const WN_MORE_DATA = 234
Const WN_NOT_SUPPORTED = 50&
Const WN_NO_NET_OR_BAD_PATH = 1203&
Const WN_NO_NETWORK = 1222&
Const WN_NOT_CONNECTED = 2250&
Public Function GetUNCName(Drive$) As String
Dim Result&, Buffer$, l&, ErrText$
Buffer = Space(255)
l = Len(Buffer)
Result = WNetGetConnection(Drive, Buffer, l)
Select Case Result
Case WN_BAD_DEVICE: ErrText = "Kein Netzlaufwerk"
Case WN_CONNECTION_UNAVAILABLE: ErrText = "Verb. nicht mögl."
Case WN_EXTENDED_ERROR: ErrText = "Schwerer Fehler"
Case WN_MORE_DATA: ErrText = "Mehr Daten"
Case WN_NOT_SUPPORTED: ErrText = "Nicht unterstützt"
Case WN_NO_NET_OR_BAD_PATH: ErrText = "Pfad nicht vorhanden"
Case WN_NO_NETWORK: ErrText = "Netzw. n. verfügbar"
Case WN_NOT_CONNECTED: ErrText = "Nicht verbunden"
Case Else: ErrText = ""
End Select
If ErrText <> "" Then
MsgBox ErrText
Else
GetUNCName = WorksheetFunction.Trim(Left$(Buffer, l))
End If
End Function
Sub ServerName()
Dim pfad As String
Dim laenge As Integer
Dim laufwerk As String
Dim pfadohnelw As String
Dim serverpfad As String
pfad = ThisWorkbook.Path
laenge = Len(pfad)
laufwerk = Left(pfad, InStr(1, pfad, ":", vbBinaryCompare))
pfadohnelw = Right(pfad, laenge - InStr(1, pfad, ":", vbBinaryCompare))
serverpfad = GetUNCName(Left(pfad, InStr(1, pfad, ":", vbBinaryCompare)))
MsgBox serverpfad & pfadohnelw
End Sub

Answer 2

Hallo nighty,

vielen Dank für den Tipp, ich werde das an meinem privaten Rechner mal testen.

Aktuell habe ich mit eben diesen Hyperlinks das Problem, dass ich

ab 219Zeichen Pfadlänge einen:
Laufzeitfehler 1004: "Pfad" wurde nicht gefunden...

ab 256Zeichen Pfadlänge:
die Fehlermeldung bekomme, dass "open" f.d. "workbook" fehgeschlgen ist.

Die 256 könte ich mir ja noch erklären, aber gibt es vorher auch bereits eine Pfadlänge um die 219, mit der VBA Probleme bekommt?

Gruß
Jürgen