[2007] VBA "Enregistrer sous" autre nom

Bonsoir,

depuis que je programme je n'avais pas eu a faire cette manip !!
FATIGUE ou pas les yeux en face les trous ou modif sur 2007
enfin....pas d'excuses je n'arrive pas a trouver le code pour enregistrer une base active sous un autre nom équivalent "Enregistrer sous". ça devrait être un SaveAs de l'Application mais il me manque quelque chose.

merci du coup de main

Salut,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
Private Sub Cmd_Save_Data_BDD_Click()
    'Sauvegarde de la base des DATA sous Nom_Base_19_05_2008_.bak.mdb
    On Error GoTo err
 
    Dim Msg As String
    Dim fso As Object
    Dim StrCopie As String 'Chemin et nom de la copie BDD DATA
    Dim MyStrDateDay As String
    Dim MyStrDateMonth As String
    Dim MyStrDateYear As String
    Dim NomSaveDATA As String 'Nom du fichier de la sauvegarde modifié dans la boîte de dialogue Input
    Dim VarNameBDD_DATA As String 'Nom de la BDD DATA
    Dim VarNameDriveBDD_DATA As String
    Dim VarNameSaveBDD_DATA As String
 
    MyStrDateDay = Format(Date, "dd") 'Donne le jour
    MyStrDateMonth = Format(Date, "mm") 'Donne le mois
    MyStrDateYear = Format(Date, "yyyy") 'Donne l'année
 
    ' Retrouve le chemin complet de la base attachée
    Dim VarTableAppli As String
    VarTableAppli = "T_Nom_Table"'Mettre le nom d'une table
    VarNameBDD_DATA = GetLinkedDBName(VarTableAppli) 'Va à la function GetLinkedDBName
 
 
    VarNameDriveBDD_DATA = DriveLinkedTable
 
    'Chemin et nom de la Base DATA avec _dd_mm_yyyy
    StrCopie = Left(VarNameBDD_DATA, Len(VarNameBDD_DATA) - 4) & "_" & MyStrDateDay & _
                                                                  "_" & MyStrDateMonth & _
                                                                  "_" & MyStrDateYear & "_" & _
                                                                  ".bak." & Right(VarNameBDD_DATA, 3)
    Dim i As Integer
    Dim X As String
    Dim Path As String
 
        'Boucle pour ne prendre que le Nom de la Base DATA
    For i = Len(StrCopie) To 1 Step -1
        If Mid$(StrCopie, i, 1) = "\" Then Exit For
    Next
 
    NomSaveDATA = Right(StrCopie, Len(StrCopie) - i)
   'Ouvre la boite de dialogue Enregistrer sous de windows
    Dim StrSaveAs As String
    StrSaveAs = EnregistrerUnFichier(Me.hwnd, "Enregistrer Base DATA sous", NomSaveDATA, VarNameDriveBDD_DATA) 'Fonction dans Module
 
   If ChoixSaveAs = False Then Exit Sub
 
    'Vérification de l'existance du fichier dans le dossier
    Dim oFSO As Scripting.FileSystemObject
    Dim oFl As Scripting.File
    Dim MsgFileExist As String
 
    'Instance du FSO
    Set oFSO = New Scripting.FileSystemObject
    'Instance de l'objet File
    If oFSO.FileExists(NomSaveDATA) Then
        MsgFileExist = MsgBox("Ce nom de fichier existe déjà." & vbCrLf & vbCrLf & VarNameDriveBDD_DATA & NomSaveDATA & vbCrLf & vbCrLf & "Voulez-vous continuer?", vbCritical + vbYesNo, "Save DATA")
        If MsgFileExist = vbNo Then
            Exit Sub
        End If
        Set oFl = oFSO.GetFile(NomSaveDATA)
    End If
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CopyFile VarNameBDD_DATA, NomSaveDATA 'Création de la sauvegarde
    Set fso = Nothing
    Msg = MsgBox("Votre base DATA a été sauvée sous le nom " & vbCrLf & vbCrLf & VarNameDriveBDD_DATA & NomSaveDATA, vbInformation + vbOKOnly, "Save DATA")
 
fin:
    Exit Sub
err:
    Select Case err.Number
        Case 53: MsgBox "Le fichier est introuvable"
        Case Else: MsgBox "Erreur inconnue" & err.Number & err.Description
    End Select
End Sub
 
Function GetLinkedDBName(TableName As String)
    ' *** ex: GetLinkedDBName ("Nom Table")
    ' *** Drive\Répertoire base de données\Base_de_donnees.mdb
    '
    Dim db As Database, Ret
    On Error GoTo DBNameErr
 
    Set db = CurrentDb()
    Ret = db.TableDefs(TableName).Connect
    'Retire le début de la chaîne (DATABASE=) pour garder Drive\Répertoire base de données\Base_de_donnees.mdb
    GetLinkedDBName = Right(Ret, Len(Ret) - (InStr(1, Ret, "DATABASE=") + 8))
    Exit Function
 
DBNameErr:
    GetLinkedDBName = 0
End Function
 
Function DriveLinkedTable() As String
    ' Retrouve le chemin de la base attachée
    ' ex: Drive\Dossier base de données\
    Dim X As String, i As Integer
    Dim Path As String
    Dim VarTableAppli As String
 
    VarTableAppli = "T_Nom_Table" 'Nom d'une table de l'application
 
    X$ = GetLinkedDBName(VarTableAppli) ''Va à la function GetLinkedDBName
    'Boucle pour ne prendre que le drive et le dossier
    For i = Len(X$) To 1 Step -1
        If Mid$(X$, i, 1) = "\" Then Exit For
    Next
 
    Path$ = Left$(X$, i - 1) & "\"
    DriveLinkedTable = Path$
End Function

Fonction (EnregistrerUnFichier) dans un Module

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Compare Database
Public ChoixSaveAs As Boolean 'Si on choisi Annuler
 'Déclaration de l API
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
        Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) _
        As Long
 'Structure du fichier
Private Type OPENFILENAME
  lStructSize As Long
  hWndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  Flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
 
Function EnregistrerUnFichier(Handle As Long, Titre As String, _
                    NomFichier As String, Chemin As String) As String
    ChoixSaveAs = True
    'EnregistrerUnFichier est la fonction a utiliser pour ouvrir
    'la boîte de dialogue d'enregistrement d'un fichier.
    'paramètres :
    'Handle = le handle de la fenêtre (Me.Hwnd)
    'Titre = Titre de la boîte de dialogue
    'NomFichier = Nom par défaut du fichier à enregistrer
    'Chemin = Chemin par défaut du fichier à enregistrer
 
    Dim structSave As OPENFILENAME
 
    With structSave
        .lStructSize = Len(structSave)
        .hWndOwner = Handle
        .nMaxFile = 255
        .lpstrFile = NomFichier & String$(255 - Len(NomFichier), 0)
        .lpstrInitialDir = Chemin
        .lpstrFilter = "Tous (*.*)" & Chr$(0) & "*.mdb" & Chr$(0) 'Définition du filtre (aucun)
        .Flags = &H4 'Option de la boite de dialogue
    End With
 
    If (GetSaveFileName(structSave)) Then
        EnregistrerUnFichier = Mid$(structSave.lpstrFile, 1, InStr(1, structSave.lpstrFile, vbNullChar) - 1)
    Else
        ChoixSaveAs = False 'Si on a choisi Annuler
    End If
 
End Function

Voilà, je pense que je n'ai rien oublié

salut et merci de ta réponse
avant de poster j'aurai du m'apercevoir que sous access "l'enregistrer sous" ne concernait qu'un objet de la base et que pour enregistrer celle-ci sous un autre nom en fait on passait par enregistrer sous un autre format !!!!! même si bien sur on propose le format en cours !!! - mais on fait les choses tellement machinalement.....
comprenant qu'en fait on devait faire en fait une copie - sur mes recherches j'en etais à FSO CopyFile, mais pas facile quand on a pas l'habitude, ton post tombe a point pour m'aider je vais essayer d'adapter
encore merci
je ne met pas encore résolu pour laisser ouverte la discussion j'ai vu que quand même cela semble interresser quelques personnes
a+

voilà quand on s'est aperçu que c'est copier au lieu d'enregistrer ça devient plus sinon facile mais clair
pour ceux que cela intéresse et comme je n'ai pas besoin de faire des vérifications dans les dossiers ci-après 2 codes simples pour copier avec FSO.
pres requis - Références : Microsoft Scripting Runtime

Copy d'une base a partir d'une autre base "sinon pas autorisé"
Code:

1 2 3 4 Function CopierBaseExterne() FileCopy "C:\DOSSIER\AncienNom.accdb", _ "C:\DOSSIER\NouveauNOM.accdb" End function
Copy de la base en cours :
Code:

1 2 3 4 5 6 7 8 9 10 11 Function CopierBaseOuverte() BaseOuv = CurrentDb.Name NleBase = "c:\DOSSIER\NOUVELLE_base.accdb" Set fso = CreateObject("scripting.FileSystemObject") fso.CopyFile BaseOuv, NleBase Set fso = Nothing End Function
Attention si le dossier existe il est écrasé - si on veut éviter il faut lancer une recherche préalable - adapter post electrosat03

à bientôt pour de nouvelles aventures sous prog Windoms