map en sub mappen maken van uit acces

Status
Niet open voor verdere reacties.

jo geuens

Gebruiker
Lid geworden
13 feb 2010
Berichten
190
hoi ik wil mappen en submappen aanmaken via access met vba

nu kan ik al wel een nieuwe map maken met de naam van de klant maar nu zou ik ook submappen hier willen onder maken
Code:
Function CreateFolder(strFolder)
'Aanroepen met:     CreateFolder "H:\Algemeen\Kwaliteit\Creatie_producten\"
Dim oFSO
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FolderExists(strFolder) Then
        Exit Function
    Else
        CreateFolder (oFSO.GetParentFolderName(strFolder))
    End If
    oFSO.CreateFolder (strFolder)
    Set oFSO = Nothing
End Function

Code:
Private Sub Klantenfiche_Click()
   
    'CreateFolder "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value
If Dir("G:\Klanten\Nieuwe klant\", vbDirectory) = "" Then


If MsgBox(prompt:="Map nieuwe klant bestaat niet. Wil je deze aanmaken ?", Buttons:=vbYesNo) = vbNo Then

Application.Quit
Else: CreateFolder "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value 
[COLOR="#FF0000"]If Dir("G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value \Schema's\", vbDirectory) = "" Then
MkDir "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value \Schema's\"[/COLOR]

bij de 2 laatste regel krijg ik een fout melding
 
Laatst bewerkt:
Als je zegt een foutmelding te krijgen is het wel zo handig deze er ook bij te vertellen.

Daarnaast, haal die : achter Else weg en zet die drie regels er onder.
Eindig vervolgens met End If daar weer onder.
Sluit de andere If's ook af met een bijbehorende End If
 
foutmelding

hoi edmoor

deze fout melding krijg ik
Knipsel.PNG
de : achter Else krijg ik ook niet weg
 
Code:
Private Sub Klantenfiche_Click()
    'CreateFolder "G:\Klanten AED\" & Me.Naam.Value & Me.Voornaam.Value
If Dir("G:\Klanten\Nieuwe klant\", vbDirectory) = "" Then


If MsgBox(prompt:="Map nieuwe klant bestaat niet. Wil je deze aanmaken?", Buttons:=vbYesNo) = vbNo Then

Application.Quit


Else
CreateFolder "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value
CreateFolder "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value \ Schema



End If
 End If

zoiets dan maar nadat de eerste map gemaakt is krijg ik fout (typen komen niet overeen ) op de regel waar de map schema gemaakt zou moeten worden
 
Ik kan het hier niet testen, maar probeer het eens zo:
Code:
Private Sub Klantenfiche_Click()
   [COLOR="#008000"] 'CreateFolder "G:\Klanten AED\" & Me.Naam.Value & Me.Voornaam.Value[/COLOR]
    If Dir("G:\Klanten\Nieuwe klant", vbDirectory) = "" Then
        If MsgBox(prompt:="Map nieuwe klant bestaat niet. Wil je deze aanmaken?", Buttons:=vbYesNo) = vbNo Then
            Application.Quit
        Else
            CreateFolder "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value
            CreateFolder "G:\Klanten\" & Me.Naam.Value & Me.Voornaam.Value & "\Schema"
        End If
    End If
End Sub

NB:
Dat van die Application.Quit weet je zeker?
Klopt dat CreateFolder wel?
 
Laatst bewerkt:
Waarom niet recursief?
Code:
Sub test()
    fPadMaken "G:\Klanten\Nieuwe klant\Testje\" & Year(Date) & "\" & Format(Date, "mmmm") & "\"
End Sub

Code:
Public Function fPadMaken(sFolder As String) As String
On Error GoTo ErrorHandler
Dim sF As String
    sF = GetPathOnly(sFolder)
    If Dir(sF, vbDirectory) = "" Then
      sF = fPadMaken(sF)
      MkDir sF
    End If
    fPadMaken = sFolder
    Exit Function
    
ErrorHandler:
    Exit Function
End Function

Code:
Public Function GetPathOnly(sPath As String) As String
    GetPathOnly = Left(sPath, InStrRev(sPath, "\", Len(sPath)) - 1)
End Function
 
Ik dacht meer aan :

Code:
Sub M_snb()
    If Dir("G:\Klanten\" & naam.value & "*", 16) = "" Then CreateObject("shell.application").Namespace("G:").NewFolder "Klanten\" & Naam.Value & Voornaam.Value & "\" &  Schema
End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan