Private
Sub
alle_Ordner_neu_Click()
Dim
lngReturn
As
Long
, lngErrorNumber
As
Long
Dim
strBuffer
As
String
Dim
intNr
As
Long
Dim
c
As
Integer
Dim
f
As
Integer
With
Worksheets(
"Projektübersicht"
).Columns(1)
c = .Cells(ActiveCell.Row, 1).
End
(xlUp).Row
c = f + 1
UserForm9.Show
if userform9.TextBox1.Text <> .......
For
c = 5
To
200
If
Worksheets(
"Projektübersicht"
).Cells(c, 1) =
""
Then
Exit
For
Application.EnableEvents =
False
lngReturn = MakeSureDirectoryPathExists(
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\\
" & "
Auftragsdokumentation_Blanco
" & "
\")
MakeSureDirectoryPathExists (
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\\
" & "
Auftragsdokumentation_Rücklauf
" & "
\
" & "
\
" & "
Fotodokumentation
" & "
\")
MakeSureDirectoryPathExists (
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\\
" & "
Auftragsdokumentation_Rücklauf
" & "
\
" & "
\
" & "
Durchführungsbestätigungen
" & "
\")
MakeSureDirectoryPathExists (
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\\
" & "
Anfrage, Angebot, Projektdaten
" & "
\
" & "
\
" & "
Kundenfotos
" & "
\")
MakeSureDirectoryPathExists (
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\\
" & "
Anfrage, Angebot, Projektdaten
" & "
\
" & "
\
" & "
Mailverkehr
" & "
\")
If
Dir(
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Verlauf.txt
") = "
"
Then
Open (
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Verlauf.txt")
For
Output
As
#1
Print #1,
"Projektverlauf:"
&
" "
&
"Datei wurde angelegt am:"
&
" "
&
Date
&
"/"
&
" "
& Time &
" "
&
"Für das Projekt:"
&
"Intern"
&
" "
& Worksheets(
"Projektübersicht"
).Cells(c, 1).Text &
" "
Close #1
End
If
If
lngReturn = 0
Then
lngErrorNumber = Err.LastDllError
strBuffer = Space$(200)
Call
FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
ByVal
0&, _
lngErrorNumber, LANG_NEUTRAL, strBuffer, 200,
ByVal
0&)
Call
MsgBox(
"Fehler: "
&
CStr
(lngErrorNumber) & vbLf & vbLf & _
strBuffer, vbCritical,
"Fehler beim Anlegen der Ordner"
)
Cells(c, 41).
Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=
"C:\" & "
Projekte
" & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 33) & "
\
" & Year(Now) & "
\
" & Worksheets("
Projektübersicht
").Cells(c, 3) & "
\
" & "
Intern
" & "
" & Worksheets("
Projektübersicht
").Cells(c, 1).Text & "
" & Worksheets("
Projektübersicht
").Cells(c, 3), TextToDisplay:="
angelegt am
" & "
" & Date & "
" & "
von
" & "
" & Environ("
COMPUTERNAME")
End
If
Next
c
End
With
Call
MsgBox(
"Die Ordner wurden erfolgreich angelegt."
, vbInformation,
"Information"
)
Application.EnableEvents =
True
Unload
Me
End
Sub