Wie per VBA ans Win-Verzeichnis "Eigene Dateien" kommen?

[TMC]

Hi,

ich suche nach einer Möglichkeit, per VBA (Excel 2000) ans Win-Verzeichnis "Eigene Dateien" zu kommen.

Prinzipiell brauch ich eine Function, die mir dieses Verzeichnis als String zurückgibt.

Z.B.
strED = GetDirEigeneDat()
Rückgabewert dann z.B. "e:\Daten\Eigene Dateien\"

Ich benötige das, weil ich dort ini-Dateien speichern möchte und wohl davon auszugehen ist, dass in diesem Verzeichnis die User auch Schreibrechte haben.

Danke schon vorab.
Matthias

[TMC]

Nach langem Suchen hab ich es nun doch gefunden:

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnima01/html/ima0187.asp

[TMC]

Wen es interessiert, hier meine Vorab-Umsetzung, um eine ini-Datei zu schreiben und auszulesen (Excel 2000 / XP / 2003).

Muss allerdings noch optimiert werden. Das ganze in einer Klasse wäre auch nicht verkehrt.

Code

'=================================================================================
'Liest und schreibt eine Ini-Datei.
'   Die ini-Datei ist wie folgt aufgebaut:
'       [Section1]
'       Entry1: Value Value
'       Entry2: Value Value
'       [Section2]
'       Entry1: Value Value
'=================================================================================
Option Explicit

'---------------------------------------------------
'Constants
'---------------------------------------------------
Private Const INI_MAIN_DIR% = 1 '1= Eigene Dateien, 2 = Desktop
Private Const INI_SUB_DIR$ = "Excel Test" 'Unterverzeichnis in INI_MAIN_DIR


'---------------------------------------------------
'API für INI
'---------------------------------------------------
Private Declare Function GetPrivateProfileString32 Lib "KERNEL32" Alias "GetPrivateProfileStringA" _
    (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
    ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Private Declare Function WritePrivateProfileString32 Lib "KERNEL32" Alias "WritePrivateProfileStringA" _
    (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Integer
    
'---------------------------------------------------
'API für SpecialFolderLocation (Desktop / Eigene Dateien)
'---------------------------------------------------
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hWnd As Long, ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Private Const CSIDL_PERSONAL = &H5 'Eigene Dateien
Private Const CSIDL_DESKTOPDIRECTORY = &H10 'Desktop-Directory
Private Const MAX_PATH = 260
Private Const NOERROR = 0

Private Sub ErrorMsg(strProcedure As String)
    
    'Errorhandler
    
    Dim strTitle As String
    Dim strMsg As String

    strTitle = "Es ist ein Fehler aufgetreten"

    strMsg = Err.Number & " - " & Err.Description & Chr(10) _
        & "Prozedur: <" & strProcedure & ">"
        
    MsgBox strMsg, vbExclamation, strTitle

End Sub

Private Function GetWinFolder(intFolder As Long) As String
    Const PROCEDURE_NAME$ = "GetWinFolder"
    '================================================================
    'lngFolder:
    '   Eigene Dateien = 1
    '   Desktop = 2
    'Return:
    '   Kompletter Pfad, z.B. "d:\Daten\Eigene Dateien\" mit abschließendem Backslash
    '================================================================
    On Error GoTo ErrHandle
    
    Dim lngPidlFound As Long
    Dim lngFolderFound As Long
    Dim lngParameter As Long
    Dim lngPidl As Long
    Dim strPath As String
    Dim strResult As String

    Select Case intFolder
    Case 1:
        lngParameter = CSIDL_PERSONAL
    Case 2:
        lngParameter = CSIDL_DESKTOPDIRECTORY
    Case Else:
        MsgBox "Error in Function <GetWinFolder>. Wrong parameter."
        Exit Function
    End Select

    strPath = Space(MAX_PATH)
    lngPidlFound = SHGetSpecialFolderLocation(0, lngParameter, lngPidl)
    If lngPidlFound = NOERROR Then
        lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
        If lngFolderFound Then
            strResult = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)
        Else
            strResult = ""
        End If
    End If
    
    CoTaskMemFree lngPidl

    If strResult = "" Then
        GetWinFolder = ""
    Else
        If Right(strResult, 1) = "\" Then
            GetWinFolder = strResult
        Else
            GetWinFolder = strResult & "\"
        End If
    End If
    
GoOut:
    Exit Function
ErrHandle:
    Call ErrorMsg(PROCEDURE_NAME)
    Resume GoOut
End Function
        
Public Function ReadINI(strFilename As String, strIniSection As String, strIniEntry As String) As String
    Const PROCEDURE_NAME$ = "ReadINI"
    '======================================================
    'Arguments:      Description:
    'strFullpath        voller Dateipfad der ini-Datei
    'strIniSection     Sektion der ini
    'strIniEntry         Eintrag in der Sektion
    '======================================================
    On Error GoTo ErrHandle
    
    Dim strTemp As String
    Dim strReturn As String
    Dim strFullpath As String
    
    strFullpath = GetWinFolder(INI_MAIN_DIR) & INI_SUB_DIR & "\" & strFilename
    strTemp = String$(255, 0) ' Size Buffer
    
    strReturn = GetPrivateProfileString32(strIniSection, strIniEntry, "", strTemp, 255, strFullpath)  ' Make API Call
    
    strTemp = Left$(strTemp, strReturn) ' Trim Buffer
    
    ReadINI = strTemp

GoOut:
    Exit Function
ErrHandle:
    Call ErrorMsg(PROCEDURE_NAME)
    Resume GoOut
End Function

Public Function WriteINI(strFilename As String, strSection As String, strEntry As String, strValue As String) As Integer
    Const PROCEDURE_NAME$ = "WriteINI"
    '======================================================
    'Arguments:      Description:
    'strFilename    Filename der ini-Datei (ohne Pfad!)
    'strSection        Sektion der ini
    'strEntry             Eintrag in der Sektion
    'strValue           Wert der geschrieben werden soll
    '----------------------------------------------------------------------------------------------
    'Return:
    '1 = writing ini was successful
    '0 = could not write ini -> not successful
    '======================================================
    On Error GoTo ErrHandle
    
    Dim strMainPath As String
    Dim strResultPath As String
    Dim strFullpath As String
    Dim intRet As Integer
    
    '----------------------------------------------------
    'Standard return value (error)
    '----------------------------------------------------
    WriteINI = 0
    
    '----------------------------------------------------
    'Erstelle Unterverzeichnis falls nicht vorhanden. Ergebnis: strResultPath
    '----------------------------------------------------
    strMainPath = GetWinFolder(INI_MAIN_DIR)
    strResultPath = strMainPath & INI_SUB_DIR
    If Dir$(strResultPath, 16) = "" Then
            MkDir strResultPath
    End If
    strResultPath = strResultPath & "\"
    
    strFullpath = strResultPath & strFilename
    
    '----------------------------------------------------
    'API Call
    '----------------------------------------------------
    WriteINI = WritePrivateProfileString32(strSection, strEntry, strValue, strFullpath)

GoOut:
    Exit Function
ErrHandle:
    Call ErrorMsg(PROCEDURE_NAME)
    Resume GoOut
End Function
Sub Beispiel_WriteINI()
    Dim intRet As Integer
    intRet = WriteINI("test.ini", "Section 01", "Name3", "hallo welt 2")
    If intRet = 1 Then
        MsgBox "ini erfolgreich geschrieben"
    Else
        MsgBox "ini konnte nicht geschrieben werden !"
    End If
End Sub

Sub Beispiel_ReadINI()
    
    Dim strReturn As String
    
    strReturn = ReadINI("test.ini", "Section 01", "Name3")
        
    MsgBox strReturn
            
End Sub