Enregistrement sans macro & Inputbox

Bonjour,

J'ai un problème qui est difficile à résoudre.

J'ai un fichier excel avec macros maintenant je le veux enregistrer sans macro .xlsx mais il me doit demander le nom du fichier et après le répertoire. Mais je reçoit un message d'erreur Où est la le problème?

Sub Speichern()

    Dim strCopyName As String
    Dim strPath As String
    Dim strName As String
    Dim Ret

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dateiname = InputBox("Après l'enregistrement le fichier se trouve sur votre desktop !" & vbCrLf & vbCrLf & "Entrer le nom du fichier:", "ENREGISTREMENT SANS MACRO")
    'If Dateiname = "" Then

    strPath = ActiveWorkbook.Path
    strName = ActiveWorkbook.Name

    Ret = BrowseForFolder("C:\")
    strCopyName = Ret & Dateiname

    ActiveWorkbook.SaveAs strCopyName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.SaveAs strPath & "\" & strName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
       'End If
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level

    Dim ShellApp As Object

     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

     'Destroy the Shell Application
    Set ShellApp = Nothing

     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

quel message d'erreur?

Bonjour à tous,

Au lieu de :

    Ret = BrowseForFolder("C:\")
    strCopyName = Ret & Dateiname

utilise :

    Ret = BrowseForFolder("C:\")
    strCopyName = Ret & "\" & Dateiname

ric

Maintenant il me donne une erreur syntax

Bonjour,

Sur ma machine, le code corrigé fonctionne bien.

ric

Bonjour à tous,

Voici le fichier test ...

ric

Aaah maintenant il marche aussi sur ma machine j'ai pas mis les "&" Très bien merci beaucoup

ric

Bonjour Ric,

J'ai remarquer aussi dans ton fichier que si tu click sur "annuler" dans la deuxième fenêtre pour faire la sélection du répertoire alors il donne de nouveau un message d'erreur

Bonjour,

Effectivement, je n'avais pas géré les annulations ... désolé.

Voici le fichier avec les corrections.

On peut annuler à l'étape Inputbox ou à la seconde étape, lors du choix du dossier de destination.

ric

Bonjour Ric,

J'ai changer un peut la macro mais maintenant de nouveau le problème avec le deuxième Annuler

Sub Enregistrement_sans_macro()

    Dim strCopyName As String
    Dim strPath As String
    Dim strName As String
    Dim Dateiname As String
    Dim Reponse As String
    Dim Ret

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.UserName = UserName

Retry:

    Reponse = InputBox("Quel est est le nom du fichier ?", "ENREGISTREMENT SANS MACRO")

  If StrPtr(Reponse) = 0 Then
  Exit Sub

    Else

    Dateiname = Reponse

    If Reponse = "" Then

    MsgBox "Enregistrement sans caractères pas possible !", vbCritical, "Service de documentation juridique"

GoTo Retry

    Else

    strPath = ActiveWorkbook.Path
    strName = ActiveWorkbook.Name

    Ret = BrowseForFolder("C:\ & Username")
    strCopyName = Ret & "\" & Dateiname

    If Ret = "" Then Exit Sub

    ActiveWorkbook.SaveAs strCopyName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.SaveAs strPath & "\" & strName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    End If
    End If

   End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level

    Dim ShellApp As Object

     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Tu dois sélectionner ou créer un dossier !", 0, OpenAt)

     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

     'Destroy the Shell Application
    Set ShellApp = Nothing

     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

Bonjour,

Tu n'as pas utilisé la Function contenue dans mon fichier, je l'ai légèrement modifiée pour gérer l'annulation à la 2e étape ... Celle-ci ...

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level

    Dim ShellApp As Object

    On Error Resume Next     ' ric correction annuler ( remonté ici )
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

     'Set the folder to that selected.  (On error in case cancelled)

    If ShellApp Is Nothing Then Exit Function     ' ric correction annuler
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

     'Destroy the Shell Application
    Set ShellApp = Nothing

     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

ric