' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _
"WNetGetConnectionA" (ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Sub createLinks()
Dim lngRow As Long, varFiles As Variant
Dim lngNext As Long, strUNC As String, strDrive As String
Dim strRubrik As String, strCheck As String, strLink As String, strDisplay As String
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With Sheets("Tabelle2") 'Tabelle mit den Dokumentenadressen in A1:Ax
varFiles = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
strDrive = Left(varFiles(1, 1), InStr(1, varFiles(1, 1), ":") - 1)
strUNC = LocalPathToUNCPath(strDrive) '"\\KRONOS\Public Share"
If Len(strUNC) Then
lngNext = 2
With Sheets("Tabelle1") 'Ausgabetbelle
For lngRow = 1 To UBound(varFiles, 1)
strCheck = Left(varFiles(lngRow, 1), InStrRev(varFiles(lngRow, 1), "\") - 1)
strCheck = Mid(strCheck, InStrRev(strCheck, "\") + 1)
If strCheck <> strRubrik Then
.Cells(lngNext, 1) = strCheck
strRubrik = strCheck
End If
strLink = strUNC & Mid(varFiles(lngRow, 1), InStr(1, varFiles(lngRow, 1), ":") + 1)
strDisplay = Mid(varFiles(lngRow, 1), InStrRev(varFiles(lngRow, 1), "\") + 1)
strDisplay = Left(strDisplay, InStrRev(strDisplay, ".") - 1)
.Hyperlinks.Add anchor:=.Cells(lngNext, 2), Address:=strLink, TextToDisplay:=strDisplay
lngNext = lngNext + 1
Next
End With
End If
ErrorHandler:
If Err.Number <> 0 Then
MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "createLinks" & vbLf & _
"Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Function LocalPathToUNCPath(MappedDrive As String) As String
'source:=http://classic.vb-faq.de/knowlib/uncpaths/
Dim lngRet As Long
Dim strUNC As String
Dim lngSize As Long
MappedDrive = Left$(MappedDrive, 1) & ":"
lngRet = WNetGetConnection(MappedDrive, strUNC, lngSize)
If lngRet = ERROR_MORE_DATA Then
strUNC = Space$(lngSize)
lngRet = WNetGetConnection(MappedDrive, strUNC, lngSize)
If lngRet = NO_ERROR Then
LocalPathToUNCPath = Left$(strUNC, InStr(1, strUNC, vbNullChar) - 1)
End If
End If
End Function