Viellt. kann das ja jmd gebrauchen. (Sollte leicht zu .NET umwandelbar sein)
Funktioniert mit momentan neuester Version.
Quellcode
- Option Explicit
- Public Enum SpecialFolderIDs
- sfidDESKTOP = &H0
- sfidPROGRAMS = &H2
- sfidPERSONAL = &H5
- sfidFAVORITES = &H6
- sfidSTARTUP = &H7
- sfidRECENT = &H8
- sfidSENDTO = &H9
- sfidSTARTMENU = &HB
- sfidDESKTOPDIRECTORY = &H10
- sfidNETHOOD = &H13
- sfidFONTS = &H14
- sfidTEMPLATES = &H15
- sfidCOMMON_STARTMENU = &H16
- sfidCOMMON_PROGRAMS = &H17
- sfidCOMMON_STARTUP = &H18
- sfidCOMMON_DESKTOPDIRECTORY = &H19
- sfidAPPDATA = &H1A
- sfidPRINTHOOD = &H1B
- sfidProgramFiles = &H10000
- sfidCommonFiles = &H10001
- End Enum
- Private Type SHITEMID
- cb As Long
- abID As Byte
- End Type
- Private Type ITEMIDLIST
- mkid As SHITEMID
- End Type
- Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, 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 Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
- Private Sub Form_Load()
- GetIEFavorites (GetSpecialFolder(sfidFAVORITES))
- End Sub
- 'http://www.shadoware.de/vb/foreachsubpath.html
- Private Sub GetIEFavorites(StartFolder As String)
- Dim sName As String
- Dim Filename As String
- Dim FolderName As String
- Dim Dirs() As String
- Dim DirsNo As Integer
- Dim i As Integer
- If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
- If DirExists(StartFolder) = False Then Exit Sub
- sName = Dir(StartFolder & "*.url")
- While Len(sName) > 0
- Filename = StartFolder & sName
- List1.AddItem GetINISetting(Filename, "InternetShortcut", "URL", "Error")
- sName = Dir
- Wend
- 'subfolder
- DirsNo = 0
- sName = Dir(StartFolder, vbDirectory)
- While Len(sName) > 0
- If sName <> "." And sName <> ".." Then
- DirsNo = DirsNo + 1
- ReDim Preserve Dirs(DirsNo) As String
- Dirs(DirsNo - 1) = sName
- End If
- sName = Dir
- Wend
- For i = 0 To DirsNo - 1
- FolderName = StartFolder & Dirs(i) & "\"
- GetIEFavorites (FolderName)
- Next
- End Sub
- 'http://www.vbarchiv.net/tipps/tipp_273-standard-system-ordner-ermitteln.html
- Public Function GetSpecialFolder(CSIDL As SpecialFolderIDs) As String
- Dim lResult As Long
- Dim IDL As ITEMIDLIST
- Dim sPath As String
- lResult = SHGetSpecialFolderLocation(100, CSIDL, IDL)
- If lResult = 0 Then
- sPath = Space$(512)
- lResult = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
- GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
- End If
- End Function
- 'http://www.activevb.de/rubriken/kolumne/kol_1/fileexists.html
- Private Function DirExists(ByVal DirectoryName As String) As Boolean
- On Error Resume Next
- DirExists = CBool(GetAttr(DirectoryName) And vbDirectory)
- On Error GoTo 0
- End Function
- 'http://www.shadoware.de/vb/ini.html
- Function GetINISetting(ByVal Filename As String, ByVal Key As String, ByVal Setting As String, ByVal Default As Variant) As Variant
- Dim Temp As String * 1024
- Call GetPrivateProfileString(Key, Setting, Default, Temp, Len(Temp), Filename)
- GetINISetting = Mid(Temp, 1, InStr(1, Temp, Chr(0)) - 1)
- End Function
Funktioniert mit momentan neuester Version.
Für ein Mindestmaß an Rechtschreibung, Interpunktion und Majuskeln!