Office: Zuverlässig den Pfad von "Eigene Dateien" per VBA herausfinden

Hallo liebes Forum,

habe ein Problem. Ich möchte unter Windows 2000 / XP per VBA den Pfad von "Eigene Dateien" herausfinden. Ich fand im Internet hierzu auch schon sicherlich 9 bis 10 verschiedene Ansätze und Lösungen! Doch jede hat ihre "Maken" bzw. funktionierte bei mir nicht!

Würde mich daher sehr freuen wenn ihr mir weiterhelfen könntet. Ich danke euch schon jetzt für die Antworten.

Gruß Fonso

:)

 

Hallo Fonso,

versuch es mal so:

' **********************************************************************
' 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

 

Hallo Fonso,

vielleicht helfen Dir folgende Links weiter:

http://www.microsoft.com/germany/msd...Ermitteln.mspx
http://www.vbapihelpline.de/ref/func...rPath&Letter=s

Hat sich erledigt, siehe oben *Smilie

In Deinem Fall müßte es dann lauten:

Code:

 

Sub Pfad_von_Eigene_Dateien()
Set WshShell = CreateObject("WScript.Shell")
strMyDocuments = WshShell.SpecialFolders("MyDocuments")
MsgBox strMyDocuments
Set WshShell = Nothing
End Sub

 

Danke für die rasche und Kompetente Hilfe

Gruß Fonso