Pfad für "Eigene Dateien" VBA
28.08.2016 18:39:51
Henner
Ich möchte den Pfad zu "Eigene Dateien" per VBA ermitteln, dies relativ zuverlässig für die gängigsten Win Versionen (bspw. XP, 9, 10). Dafür habe ich im Netz verschiedenste Lösungsansätze gefunden, diese führen bei Win10 allerdings nicht zu "Eigene Dateien" sondern zu "Eigene Dateien/Eigene Dokumente".
Folgende ("Schummel-")Lösung funktioniert bei mir nun sehr zuverlässig, ich frage mich aber ob es auch einfacher und vor allem eleganter geht:
Sub EigeneDateien()
Set WshShell = CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("Desktop")
strMyData = Left(strDesktop, Len(strDesktop) - 7)
MsgBox strMyData
Set WshShell = Nothing
End Sub
Lösung 1 aus dem Netz: (Pfad entspricht "Eigene Dokumente")
(Autor unbekannt)
Sub EigeneDateien()
Set WshShell = CreateObject("WScript.Shell")
strMyDocuments = WshShell.SpecialFolders("MyDocuments")
MsgBox strMyDocuments
Set WshShell = Nothing
End Sub
Lösung 2 aus dem Netz: (Pfad entspricht auch "Eigene Dokumente")
(Autor: Nepumuk)
Sub EigeneDateien()
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
ByVal hwndOwner As Long, _
ByVal nFolder As Long, _
pidl As ITEMIDLIST) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Type ITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ITEMID
End Type
Private Enum Foldertype
V_DESKTOP = &H0
R_PROGRAMME = &H2
V_SYSTEMSTEUERUNG = &H3
V_DRUCKER = &H4
R_EIGENE_DATEIEN = &H5
R_FAVORITEN = &H6
R_AUTOSTART = &H7
R_DOKUMENTE = &H8
R_SENDEN_AN = &H9
V_PAPIERKORB = &HA
R_STARTMENÜ = &HB
R_DESKTOP = &H10
V_ARBEITSPLATZ = &H11
V_NETZWERKUMGEBUNG = &H12
R_NETZWERKUMGEBUNG = &H13
R_FONTS = &H14
R_NEW_SHELL = &H15
R_TEMP_INTERNET = &H20
End Enum
Private Const NOERROR = 0
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"
Private Function GetPath(enum_Folder As Foldertype) As String
Dim lngResult As Long, strBuffer As String
Dim udtIDL As ITEMIDLIST
lngResult = SHGetSpecialFolderLocation(FindWindow _
(GC_CLASSNAMEMSEXCEL, vbNullString), enum_Folder, udtIDL)
If lngResult = NOERROR Then
strBuffer = Space$(512)
lngResult = SHGetPathFromIDList(ByVal udtIDL.mkid.cb, ByVal strBuffer)
If lngResult Then GetPath = Trim$(strBuffer)
End If
End Function
Public Sub test()
Dim strPath As String
strPath = GetPath(R_EIGENE_DATEIEN)
If Trim$(strPath) "" Then
strPath = Left$(strPath, Len(strPath) - 1)
MsgBox strPath
End If
End Sub
Für konstruktive Vorschläge bedanke ich mich im Voraus, ansonsten habe ich ja eine funktionierende Lösung.
Schönen Sonntag Abend & Gruss, Henner