hier für Eigene Dateien
19.07.2009 13:08:26
Tino
Hallo,
hier noch eine Version für den Ordner Eigene Dateien oder einen den Du dir aussuchst.
Option Explicit
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
ByRef ppidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Const S_OK = 0
Private Const MAX_PATH = 260
Public Enum ShellSpecialFolderConstants
ssfDESKTOP = &H0 ' <Desktop>
ssfPROGRAMS = &H2 ' Startmenü\Programme
ssfPERSONAL = &H5 ' Eigene Dateien
ssfFAVORITES = &H6 ' <Benutzer>\Favoriten
ssfSTARTUP = &H7 ' Startmenü\Programme\Autostart
ssfRECENT = &H8 ' <Benutzer>\Recent
ssfSENDTO = &H9 ' <Benutzer>\SendTo
ssfSTARTMENU = &HB ' <Benutzer>\Startmenü
ssfDESKTOPDIRECTORY = &H10 ' <Benutzer>\Desktop
ssfNETHOOD = &H13 ' <Benutzer>\Netzwerkumgebung
ssfFONTS = &H14 ' Windows\Fonts
ssfTEMPLATES = &H15 ' <Benutzer>\Vorlagen
ssfCOMMONSTARTMENU = &H16 ' All Users\Startmenü
ssfCOMMONPROGRAMS = &H17 ' All Users\Startmenü\Programme
ssfCOMMONSTARTUP = &H18 ' All Users\Startmenü\Autostart
ssfCOMMONDESKTOPDIRECTORY = &H19 ' All Users\Desktop
ssfAPPDATA = &H1A ' <Benutzer>\Anwendungsdaten
ssfPRINTHOOD = &H1B ' <Benutzer>\Druckumgebung
ssfCOOKIES = &H21 ' <Benutzer>\Cookies
ssfHISTORY = &H22 ' <Benutzer>\Lokale Einstell.\Verlauf
ssfCOMMONTEMPLATES = &H2D ' All Users\Vorlagen
ssfCOMMONDOCUMENTS = &H2E ' All Users\Dokumente
End Enum
Public Function GetSpecialFolder(ByVal Folder As ShellSpecialFolderConstants) As String
Dim tIIDL As ITEMIDLIST
Dim strPath As String
If SHGetSpecialFolderLocation(0, Folder, tIIDL) = S_OK Then
strPath = Space$(MAX_PATH)
If SHGetPathFromIDList(tIIDL.mkid.cb, strPath) <> 0 Then
GetSpecialFolder = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)
End If
End If
End Function
Sub Test()
Dim strFile As String
Dim lngPahth As Long
Dim strPfad As String
'hier einen Spezialordner angeben ssfPERSONAL = Eigene Dateien
strPfad = GetSpecialFolder(ssfPERSONAL)
strPfad = IIf(Right(strPfad, 1) = "\", strPfad, strPfad & "\")
strPfad = strPfad & "Neuer_Ordner\" 'Pfad + Name Neuer Ordner
strFile = "Kopie von " & ThisWorkbook.Name 'Dateiname für die Sicherung
'hier wird der Ordner angelegt, sollte er nicht vorhanden sein
lngPahth = apiCreateFullPath(strPfad)
'ist der Ordner vorhanden oder konnte angelegt werden = lngPahth = 1
'ist der Ordner schon vorhanden, wird er nicht überschrieben!
If lngPahth = 1 Then
ThisWorkbook.SaveCopyAs strPfad & strFile
Else
MsgBox "Ordner konnte nicht angelegt oder gefunden werden!", vbCritical
End If
End Sub
Gruß Tino