Option Explicit
Sub Beispiel()
MkDir ThisWorkbook.Path & "\" & Cells(8, 4)
End SubOption Private Module
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub DirAuswahl()
Dim Dpfad As String, Meldung As String
Dim msg As Variant
Dpfad = getdirectory(msg) & "\"
If Dir(Dpfad & Cells(8, 4), vbDirectory) <> Cells(8, 4) Then
MkDir Dpfad & Cells(8, 4)
Dpfad = Dpfad & Cells(8, 4) & "\"
Rem hier sollte deine datei wohl gespeichert werden,welche ?
Rem der pfad waere zur zeit in der variablen Dpfad ,anzufuegen waere der dateiname bzw ueber index
Else
Meldung = MsgBox("Ein Ordner mit dem Namen " & Cells(8, 4) & " gibt es schon !", vbOK)
End If
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End FunctionActiveWorkbook.SaveAs Filename:=Dpfad & "DEIN DATEI NAME" & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="" Option Private Module
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub DirAuswahl()
Dim Dpfad As String, Meldung As String
Dim msg As Variant
Dpfad = getdirectory(msg) & "\"
If Dir(Dpfad & Cells(8, 4), vbDirectory) <> Cells(8, 4) Then
MkDir Dpfad & Cells(8, 4)
Dpfad = Dpfad & Cells(8, 4) & "\"
ActiveWorkbook.SaveAs Filename:=Dpfad & ActiveWorkbook.Sheets(1).Range("D8") & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:=""
Else
Meldung = MsgBox("Ein Ordner mit dem Namen " & Cells(8, 4) & " gibt es schon !", vbOK)
End If
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function
Ordner aus Zellen erstellen
Wuschl32 17.04.2007 - 113 Hits - 3 Antworten
Datei automatisch in einen Ordner Speichern
Elhamplo 11.07.2008 - 170 Hits - 2 Antworten