Probleme sur un code vba sur access [Résolu]

Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
- - Dernière réponse : yg_be
Messages postés
8295
Date d'inscription
lundi 9 juin 2008
Statut
Contributeur
Dernière intervention
18 août 2019
- 17 juil. 2019 à 19:37
Bonjour à tous,

J'ai un souci sur acces. on vient de passez de 32 à 64 bits et j'ai se code qui fonctionne plus.
Si quelqu'un connait une solution sachant que je ne peut pas revenir à la version 32 bits.

J'ai mis en gras la ou ca bug.

<code>Private Sub Commande0_Click()
Dim le_champ As Control
Set le_champ = Forms!Menu!liste_imports
DoCmd.SetWarnings False
fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier Excel", "xls")
' le_champ.SourceObject = ""
DoCmd.TransferSpreadsheet acImport, , "info", fichier_importe, True
requete = "UPDATE info SET fichier = '" & Dir(fichier_importe) & "' " & _

"WHERE fichier is null"
DoCmd.RunSQL requete
' le_champ.SourceObject = "les imports"
le_champ.Requery
temp = PurgeErreurs()
DoCmd.SetWarnings True
End Sub<code>

Merci d'avance :)
Afficher la suite 

3 réponses

Messages postés
8295
Date d'inscription
lundi 9 juin 2008
Statut
Contributeur
Dernière intervention
18 août 2019
412
0
Merci
bonjour, merci d'utiliser les balises de code quand tu postes du code dans le forum.
je suppose que l'erreur se produit sur la première ligne en gras.
quel message d'erreur obtiens-tu?
Commenter la réponse de yg_be
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
0
Merci


J'ai ce message.
Commenter la réponse de Cailloux50
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
0
Merci


Et c'est ça qui va pas.
Cailloux50
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
-
Quand je fais pas a pas la valeur de fichier_importe est =""


Voici les code

Dans From_Menu

Private Sub Commande0_Click()
Dim le_champ As Control
Set le_champ = Forms!Menu!liste_imports
DoCmd.SetWarnings False
fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier Excel", "xls")
' le_champ.SourceObject = ""
DoCmd.TransferSpreadsheet acImport, , "info", fichier_importe, True
requete = "UPDATE info SET fichier = '" & Dir(fichier_importe) & "' " & _
"WHERE fichier is null"
DoCmd.RunSQL requete
' le_champ.SourceObject = "les imports"
le_champ.Requery
temp = PurgeErreurs()
DoCmd.SetWarnings True
End Sub

Private Sub Commande24_Click()
fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier texte", "txt")
DoCmd.TransferText acImportFixed, "specification", "ST1", fichier_importe
requete = "UPDATE ST1 SET fichier_import = '" & Dir(fichier_importe) & "' " & _
"WHERE fichier_import is null"
DoCmd.RunSQL requete
fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier texte", "txt")
DoCmd.TransferText acImportFixed, "specification", "ST1", fichier_importe
requete = "UPDATE ST1 SET fichier_import = '" & Dir(fichier_importe) & "' " & _
"WHERE fichier_import is null"
DoCmd.RunSQL requete
import2.Requery
End Sub

Private Sub Commande27_Click()
Set fichier = Application.FileDialog(msoFileDialogSaveAs)
With fichier
.InitialFileName = TR![Chassis No#].Value & "_" & Year(Date) & Month(Date) & Day(Date) & ".xls"
If .Show Then
nom_fichier = .SelectedItems(1)
End If
End With
If Not (IsEmpty(nom_fichier)) Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "tracteur recherché 2bis", nom_fichier, True
End If
End Sub

Private Sub Commande32_Click()

End Sub

Private Sub Commande39_Click()
DoCmd.SetWarnings False
If MsgBox("Etes-vous sûr de vouloir supprimer les données du fichier " & liste_imports & "?", vbOKCancel) = vbOK Then
requete = "DELETE * FROM info where fichier = '" & liste_imports & "'"
DoCmd.RunSQL requete
liste_imports.Requery
End If
DoCmd.SetWarnings True
End Sub

Private Sub Commande40_Click()
DoCmd.SetWarnings False
If MsgBox("Etes-vous sûr de vouloir supprimer les données du fichier " & import2 & "?", vbOKCancel) = vbOK Then
requete = "DELETE * FROM ST1 where fichier_import = '" & import2 & "'"
DoCmd.RunSQL requete
import2.Requery
End If
DoCmd.SetWarnings True

End Sub

Private Sub Commande50_Click()
DoCmd.SetWarnings False
requete = "delete * from letableau"
DoCmd.RunSQL requete
requete = "INSERT INTO letableau ( Critère, statut, Nbre_tracteurs )SELECT tableau.Critère, tableau.statut, tableau.Nbre_tracteurs FROM tableau"
DoCmd.RunSQL requete
DoCmd.OpenTable "letableau", acViewPivotTable
DoCmd.SetWarnings True

End Sub

Private Sub Commande53_Click()
DoCmd.SetWarnings False
requete = "delete * from letableau"
DoCmd.RunSQL requete
requete = "INSERT INTO letableau ( Critère, statut, Nbre_tracteurs )SELECT tableau.Critère, tableau.statut, tableau.Nbre_tracteurs FROM tableau"
DoCmd.RunSQL requete
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "letableau", "c:/toto.xls"
DoCmd.SetWarnings True

End Sub

Private Sub Commande58_Click()
If etat = "" Then
DoCmd.OpenQuery "BAS2bis"
Else
DoCmd.OpenQuery "BAS2"
End If
End Sub

Private Sub Commande6_Click()
On Error GoTo Err_Commande6_Click


DoCmd.Quit

Exit_Commande6_Click:
Exit Sub

Err_Commande6_Click:
MsgBox Err.Description
Resume Exit_Commande6_Click

End Sub

Private Sub Commande60_Click()
Set fichier = Application.FileDialog(msoFileDialogSaveAs)
With fichier
.InitialFileName = "Liste_tracteur.xls"
If .Show Then
nom_fichier = .SelectedItems(1)
End If
End With
If Not (IsEmpty(nom_fichier)) Then
If etat = "" Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "BAS2bis", nom_fichier, True
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "BAS2", nom_fichier, True
End If
End If

End Sub

Private Sub Commande65_Click()
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from ORDXLS"
fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier texte", "txt")
DoCmd.TransferText acImportDelim, "ORDXLS", "ORDXLS", fichier_importe, True
requete = "UPDATE param SET info = '" & Date & "," & Time & "' WHERE id_param ='ord'"
DoCmd.RunSQL requete
tracteurs_dispo_date.Requery
DoCmd.SetWarnings True

MsgBox ("Import Terminé")
End Sub

Private Sub Commande66_Click()
Set fichier = Application.FileDialog(msoFileDialogSaveAs)
With fichier
.InitialFileName = "Liste_tracteurs_dispos.xls"
If .Show Then
nom_fichier = .SelectedItems(1)
End If
End With
If Not (IsEmpty(nom_fichier)) Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "trateurs dispos", nom_fichier, True
End If

End Sub

Private Sub Commande7_Click()
DoCmd.SetWarnings False
TR.SourceObject = ""
Dim tbl As TableDef
For Each tbl In CurrentDb.TableDefs
If tbl.Name = "factures n" Then
Debug.Print "Effacement de " & tbl.Name
CurrentDb.TableDefs.Delete tbl.Name
End If
Next tbl

Set tbl = Nothing

fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier Excel", "xlsm")
DoCmd.TransferSpreadsheet acImport, , "factures n", fichier_importe, True, "factures n!A:AJ"
requete = "DELETE * FROM [factures n] WHERE M is Null"
DoCmd.RunSQL requete
temp = PurgeErreurs()
requete = "UPDATE param SET info = '" & Dir(fichier_importe) & " importé le " & Date & "' " & "WHERE id_param ='facturen'" _

DoCmd.RunSQL requete
fichier_factures_n.Requery
DoCmd.SetWarnings True
TR.SourceObject = "tracteur recherché"

MsgBox ("Import Terminé")
End Sub




Dans module 1

Option Compare Database
'CODE récupéré sur developpez.com

'Déclaration de l'API
Private Declare PtrSafe Sub PathStripPath Lib "shlwapi.dll" Alias "PathStripPathA" (ByVal pszPath As String)
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (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

'Constantes
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000

Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0


Public Function OuvrirUnFichier(Handle As Long, _
Titre As String, _
TypeRetour As Byte, _
Optional TitreFiltre As String, _
Optional TypeFichier As String, _
Optional RepParDefaut As String) As String
'OuvrirUnFichier est la fonction a utiliser dans votre formulaire pour ouvrir _
'la boîte de dialogue de sélection d'un fichier.
'Explication des paramètres
'Handle = le handle de la fenêtre (Me.Hwnd)
'Titre = Titre de la boîte de dialogue
'TypeRetour (Définit la valeur, de type String, renvoyée par la fonction)
'1 = Chemin complet + Nom du fichier
'2 = Nom fichier seulement
'TitreFiltre = Titre du filtre
'Exemple: Fichier Access
'N'utilisez pas cet argument si vous ne voulez spécifier aucun filtre
'TypeFichier = Extention du fichier (Sans le .)
'Exemple: MDB
'N'utilisez pas cet argument si vous ne voulez spécifier aucun filtre
'RepParDefaut = Répertoire d'ouverture par defaut
'Exemple: C:\windows\system32
'Si vous laissé l'argument vide, par defaut il se place dans le répertoire de votre application

Dim StructFile As OPENFILENAME
Dim sFiltre As String

'Construction du filtre en fonction des arguments spécifiés
If Len(TitreFiltre) > 0 And Len(TypeFichier) > 0 Then
sFiltre = TitreFiltre & " (" & TypeFichier & ")" & Chr$(0) & "*." & TypeFichier & Chr$(0)
End If
sFiltre = sFiltre & "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0)


'Configuration de la boîte de dialogue
With StructFile
.lStructSize = Len(StructFile) 'Initialisation de la grosseur de la structure
.hwndOwner = Handle 'Identification du handle de la fenêtre
.lpstrFilter = sFiltre 'Application du filtre
.lpstrFile = String$(254, vbNullChar) 'Initialisation du fichier '0' x 254
.nMaxFile = 254 'Taille maximale du fichier
.lpstrFileTitle = String$(254, vbNullChar) 'Initialisation du nom du fichier '0' x 254
.nMaxFileTitle = 254 'Taille maximale du nom du fichier
.lpstrTitle = Titre 'Titre de la boîte de dialogue
.flags = OFN_HIDEREADONLY 'Option de la boite de dialogue
If ((IsNull(RepParDefaut)) Or (RepParDefaut = "")) Then
RepParDefaut = CurrentDb.Name
PathStripPath (RepParDefaut)
.lpstrInitialDir = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Mid$(RepParDefaut, 1, _
InStr(1, RepParDefaut, vbNullChar) - 1)))
Else: .lpstrInitialDir = RepParDefaut
End If
End With

If (GetOpenFileName(StructFile)) Then 'Si un fichier est sélectionné
Select Case TypeRetour
Case 1: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFile, InStr(1, StructFile.lpstrFile, vbNullChar) - 1))
Case 2: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFileTitle, InStr(1, StructFile.lpstrFileTitle, vbNullChar) - 1))
End Select
End If

End Function


Public Function PurgeErreurs()

Dim tbl As TableDef
For Each tbl In CurrentDb.TableDefs
If InStr(tbl.Name, "importerrors") Or InStr(tbl.Name, "Échec") Or InStr(tbl.Name, "factures n$A:AJ_ImportErrors") Then
Debug.Print "Effacement de " & tbl.Name
CurrentDb.TableDefs.Delete tbl.Name
End If
Next tbl

Set tbl = Nothing

End Function




Dans Module 2
Option Compare Database







Sachant que je vient de passez en excel 64 bits et c'est pour ça que ça fonctionne plus.

DoCmd.TransferSpreadsheet acImport


Pour l'instant c'est que cette partie la qui bug
yg_be
Messages postés
8295
Date d'inscription
lundi 9 juin 2008
Statut
Contributeur
Dernière intervention
18 août 2019
412 > Cailloux50
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
-
merci d'utiliser le type "basic" quand tu postes du code VBA.
je suggère de remplacer la ligne
fichier_importe = OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier Excel", "xls")

par
Dim fichier_importe As String, f    As Office.FileDialog
 Set f = Application.FileDialog(msoFileDialogFilePicker)
 f.AllowMultiSelect = False
 f.Show
 fichier_importe = f.SelectedItems(1)
Cailloux50
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
-
access 64 bits *
Cailloux50
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
-
Merci beaucoup visiblement c'est bon ;)

Je connaissais pas Office.FileDialog

Merci pour tout
yg_be
Messages postés
8295
Date d'inscription
lundi 9 juin 2008
Statut
Contributeur
Dernière intervention
18 août 2019
412 > Cailloux50
Messages postés
76
Date d'inscription
jeudi 13 septembre 2018
Statut
Membre
Dernière intervention
30 juillet 2019
-
parfait! peux-tu alors marquer le sujet comme résolu?
Commenter la réponse de Cailloux50