der folgende Code von Nepumuk schreibt unter Windows - u. Office 2000
in Spalte A den Hyperlink der jeweiligen Internetverknüpfungsdatei -
unter XP/Excel 2003 wird hingegen der Dateipfad ausgegeben.
Hat jemand eine Erklärung bzw. eine Lösung für XP?
hG
Rolf
Option Explicit
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
ByVal hwndOwner As Long, _
ByVal nFolder As Long, _
ByRef pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Type ITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ITEMID
End Type
Private Const R_FAVORITS = &H6
Private Const NOERROR = 0&
Private Const GCCLASSNAMEMSEXCEL = "XLMAIN"
Private myFileSystemObject As Object, myFolder As Object
Public Sub Read_Favorits()
Dim lngRow As Long
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
Call FindFiles(GetPath(R_FAVORITS), lngRow)
Set myFileSystemObject = Nothing
End Sub
Private Sub FindFiles(ByVal strPath As String, ByRef lngRow As Long)
Call GetFilesInFolder(strPath, lngRow)
For Each myFolder In myFileSystemObject.GetFolder(strPath).SubFolders
Call FindFiles(myFolder.Path & "\", lngRow)
Next
End Sub
Private Sub GetFilesInFolder(ByVal strPath As String, ByRef lngRow As Long)
Dim myfile As File
For Each myfile In myFileSystemObject.GetFolder(strPath).Files
If LCase$(Right$(myfile.Name, 4)) = ".url" Then
With Application.FileSearch
.LookIn = strPath
.Filename = Left$(myfile.Name, Len(myfile.Name) - 4)
.FileType = msoFileTypeAllFiles
If .Execute = 1 Then
lngRow = lngRow + 1
Cells(lngRow, 1).Value = .FoundFiles(1)
Cells(lngRow, 2).Value = Left$(myfile.Name, Len(myfile.Name) - 4)
End If
End With
End If
Next
End Sub
Private Function GetPath(lNumber As Long) As String
Dim lResult As Long, lBuffer As String
Dim Idl As ITEMIDLIST
lResult = SHGetSpecialFolderLocation(FindWindow(GCCLASSNAMEMSEXCEL, _
Application.Caption), lNumber, Idl)
If lResult = NOERROR Then
lBuffer = Space$(512)
lResult = SHGetPathFromIDList(ByVal Idl.mkid.cb, ByVal lBuffer)
If lResult Then _
GetPath = Left$(lBuffer, Len(Trim$(lBuffer)) - 1) & "\"
End If
End Function