J'arrive =E0 utiliser la macro Transf=E9rerFeuilleCalcul ( pour ins=E9rer
des donn=E9es excell dans ma base)
par contre j'aimerais ne pas avoir =E0 mettre en dur le chemin du
fichier.
l'id=E9al serait qu'une fen=EAtre s'ouvre pour le choisir.
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
FFO
Salut JB
J'avais eu la même demande dans le temps et un généreux contributeur m'avait donné ces codes qui si ils sont trés lourd dans leur structure fonctionnent trés bien :
Dans module global :
Option Compare Database Option Explicit
Public Enum Selection Mono_Sélection = 1 Multi_Sélection = 2 End Enum
Public Enum acOpenFileType AllFiles Image MSOffice MultiMedia Sound texte End Enum
Public Const OFN_AllowMultiSelect = &H200 Public Const OFN_CreatePrompt = &H2000 Public Const OFN_EnableHook = &H20 Public Const OFN_EnableTemplate = &H40 Public Const OFN_EnableTemplateHandle = &H80 Public Const OFN_EXPLORER = &H80000 Public Const OFN_ExtensionDifferent = &H400 Public Const OFN_FileMustExist = &H1000 Public Const OFN_HideReadOnly = &H4 Public Const OFN_LongNames = &H200000 Public Const OFN_NoChangeDir = &H8 Public Const OFN_NoDeReferenceLinks = &H100000 Public Const OFN_NoLongNames = &H40000 Public Const OFN_NoNetWorkButton = &H20000 Public Const OFN_NoReadOnlyReturn = &H8000 Public Const OFN_NoTestFileCreate = &H10000 Public Const OFN_NoValiDate = &H100 Public Const OFN_OverWritePrompt = &H2 Public Const OFN_PathMustExist = &H800 Public Const OFN_ReadOnly = &H1 Public Const OFN_ShareAware = &H4000 Public Const OFN_ShareFallThrough = 2 Public Const OFN_ShareNoWarn = 1 Public Const OFN_ShareWarn = 0 Public Const OFN_ShowHelp = &H10 Public Dialogue As OpenFileName Public strFiltre As String Public strFile As String Public strNomFile As String Public RetVal As Long Public tOpenFile As Variant Public nOpenFile As Long Public FileType As acOpenFileType
Public Type OpenFileName lStructSize As Long hwndOwner As Long Instance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustomFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpInitialFolder 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long Public Declare Function GetSaveFileName Lib "comdlg32.dll" _ Alias "GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
Public Function OpenFile( _ Optional InitialFolder As String = "d:", _ Optional MultiSelect As Selection = Mono_Sélection, _ Optional ModalWindow As Boolean = True, _ Optional FileType As acOpenFileType = texte, _ Optional KbBufferLength As Long = 4, _ Optional WithPath As Boolean = True, _ Optional NewFile As Boolean = True _ ) As String OpenFile = "" 'If InitialFolder = "" Then InitialFolder = "I:TouusersMapsCatalogueX01" Dim Id 'Id = OpenFile(, Multi_Sélection, True, texte, 12, False) 'Id = OpenFile(, Multi_Sélection, True, allfiles, 12, False) 'pour tous 'Id = OpenFile("CheminRepertoire", Multi_Sélection, True, allfiles, 12, False)
If KbBufferLength < 4 Or KbBufferLength > 63 Then KbBufferLength = 4 End If ExtendChoose FileType With Dialogue If ModalWindow Then .hwndOwner = Access.hWndAccessApp Else .hwndOwner = 0 End If .lStructSize = Len(Dialogue) .lpstrFilter = strFiltre .lpInitialFolder = InitialFolder 'Recherche du fichier précédent If Not NewFile Then .lpstrTitle = "Recherche du fichier ancien " Else 'Recherche du nouveau fichier .lpstrTitle = "Recherche du fichier nouveau " End If '.lpstrTitle = "Recherche du fichier nouveau " '& IIf(Not NewFile, "ancien", "") 'Indication Boite de dialogue du 2° fichier If MultiSelect = Mono_Sélection Then .lpstrFile = Space(254) .nMaxFile = 255 .lpstrFileTitle = Space(254) .nMaxFileTitle = 255 .Flags = 6148 Else .lpstrFile = Space((KbBufferLength * 4096) - 2) .nMaxFile = ((KbBufferLength * 4096) - 1) .lpstrFileTitle = Space((KbBufferLength * 4096) - 2) .nMaxFileTitle = ((KbBufferLength * 4096) - 1) .Flags = 6148 Or OFN_FileMustExist _ Or OFN_EXPLORER _ Or OFN_AllowMultiSelect End If End With RetVal = GetOpenFileName(Dialogue) If RetVal = 0 Then OpenFile = "" nOpenFile = 0 Exit Function End If OpenFile = Trim(Dialogue.lpstrFile) OpenFile = Left(OpenFile, Len(OpenFile) - 1) OpenFile = Replace(OpenFile, Chr(0), ";") tOpenFile = Split(OpenFile, ";") If UBound(tOpenFile) = 0 Then nOpenFile = 1 ElseIf UBound(tOpenFile) = 1 Then OpenFile = Replace(OpenFile, ";", "") nOpenFile = 1 Else nOpenFile = UBound(tOpenFile) - 1 End If If Not WithPath Then If InStr(1, OpenFile, ";") > 0 Then OpenFile = Mid(OpenFile, InStr(1, OpenFile, ";") + 1) Else OpenFile = Mid(OpenFile, InStrRev(OpenFile, "") + 1) End If End If End Function
Public Function SaveFile(Optional InitialFolder As String = "", _ Optional FileType As acOpenFileType = AllFiles _ ) As String SaveFile = "" If InitialFolder = "" Then InitialFolder = "I:TouusersMapsCatalogueX01" ExtendChoose FileType With Dialogue .hwndOwner = Access.hWndAccessApp .lStructSize = Len(Dialogue) .lpstrFilter = strFiltre .lpstrFile = Space(254) .nMaxFile = 255 .lpstrFileTitle = Space(254) .nMaxFileTitle = 255 .lpInitialFolder = InitialFolder .lpstrTitle = "Sauvegarde d'un fichier" .Flags = 6148 End With RetVal = GetSaveFileName(Dialogue) If RetVal >= 1 Then SaveFile = Trim(Dialogue.lpstrFile) SaveFile = Replace(SaveFile, Chr(0), "") Else SaveFile = "" Exit Function End If End Function
Dans module d’importation : Public Function Import() As Boolean Dim SelectedFile As String ' Utilisation de rep déclaré en Optionnel ' et visualisation des fichiers textes SelectedFile = OpenFile("C:Chemin", , , texte, NewFile:úlse) 'SelectedFile = OpenFile() If Len(SelectedFile) > 0 Then 'MsgBox SelectedFile 'Adapter le nom de la table DoCmd.TransferText acImportFixed, "Fichier", "Table", SelectedFile, True End If SelectedFile = OpenFile("C:Chemin", , , texte) 'SelectedFile = OpenFile() If Len(SelectedFile) > 0 Then 'MsgBox SelectedFile 'Adapter le nom de la table DoCmd.TransferText acImportFixed, "Fichier", "Table", SelectedFile, True End If End Function
Essaies et dis moi !!!!!
Salut JB
J'avais eu la même demande dans le temps et un généreux contributeur m'avait
donné ces codes qui si ils sont trés lourd dans leur structure fonctionnent
trés bien :
Dans module global :
Option Compare Database
Option Explicit
Public Enum Selection
Mono_Sélection = 1
Multi_Sélection = 2
End Enum
Public Enum acOpenFileType
AllFiles
Image
MSOffice
MultiMedia
Sound
texte
End Enum
Public Const OFN_AllowMultiSelect = &H200
Public Const OFN_CreatePrompt = &H2000
Public Const OFN_EnableHook = &H20
Public Const OFN_EnableTemplate = &H40
Public Const OFN_EnableTemplateHandle = &H80
Public Const OFN_EXPLORER = &H80000
Public Const OFN_ExtensionDifferent = &H400
Public Const OFN_FileMustExist = &H1000
Public Const OFN_HideReadOnly = &H4
Public Const OFN_LongNames = &H200000
Public Const OFN_NoChangeDir = &H8
Public Const OFN_NoDeReferenceLinks = &H100000
Public Const OFN_NoLongNames = &H40000
Public Const OFN_NoNetWorkButton = &H20000
Public Const OFN_NoReadOnlyReturn = &H8000
Public Const OFN_NoTestFileCreate = &H10000
Public Const OFN_NoValiDate = &H100
Public Const OFN_OverWritePrompt = &H2
Public Const OFN_PathMustExist = &H800
Public Const OFN_ReadOnly = &H1
Public Const OFN_ShareAware = &H4000
Public Const OFN_ShareFallThrough = 2
Public Const OFN_ShareNoWarn = 1
Public Const OFN_ShareWarn = 0
Public Const OFN_ShowHelp = &H10
Public Dialogue As OpenFileName
Public strFiltre As String
Public strFile As String
Public strNomFile As String
Public RetVal As Long
Public tOpenFile As Variant
Public nOpenFile As Long
Public FileType As acOpenFileType
Public Type OpenFileName
lStructSize As Long
hwndOwner As Long
Instance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpInitialFolder 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
Public Function OpenFile( _
Optional InitialFolder As String = "d:", _
Optional MultiSelect As Selection = Mono_Sélection, _
Optional ModalWindow As Boolean = True, _
Optional FileType As acOpenFileType = texte, _
Optional KbBufferLength As Long = 4, _
Optional WithPath As Boolean = True, _
Optional NewFile As Boolean = True _
) As String
OpenFile = ""
'If InitialFolder = "" Then InitialFolder =
"I:TouusersMapsCatalogueX01"
Dim Id
'Id = OpenFile(, Multi_Sélection, True, texte, 12, False)
'Id = OpenFile(, Multi_Sélection, True, allfiles, 12, False) 'pour tous
'Id = OpenFile("CheminRepertoire", Multi_Sélection, True, allfiles, 12, False)
If KbBufferLength < 4 Or KbBufferLength > 63 Then
KbBufferLength = 4
End If
ExtendChoose FileType
With Dialogue
If ModalWindow Then
.hwndOwner = Access.hWndAccessApp
Else
.hwndOwner = 0
End If
.lStructSize = Len(Dialogue)
.lpstrFilter = strFiltre
.lpInitialFolder = InitialFolder
'Recherche du fichier précédent
If Not NewFile Then
.lpstrTitle = "Recherche du fichier ancien "
Else
'Recherche du nouveau fichier
.lpstrTitle = "Recherche du fichier nouveau "
End If
'.lpstrTitle = "Recherche du fichier nouveau " '& IIf(Not NewFile,
"ancien", "") 'Indication Boite de dialogue du 2° fichier
If MultiSelect = Mono_Sélection Then
.lpstrFile = Space(254)
.nMaxFile = 255
.lpstrFileTitle = Space(254)
.nMaxFileTitle = 255
.Flags = 6148
Else
.lpstrFile = Space((KbBufferLength * 4096) - 2)
.nMaxFile = ((KbBufferLength * 4096) - 1)
.lpstrFileTitle = Space((KbBufferLength * 4096) - 2)
.nMaxFileTitle = ((KbBufferLength * 4096) - 1)
.Flags = 6148 Or OFN_FileMustExist _
Or OFN_EXPLORER _
Or OFN_AllowMultiSelect
End If
End With
RetVal = GetOpenFileName(Dialogue)
If RetVal = 0 Then
OpenFile = ""
nOpenFile = 0
Exit Function
End If
OpenFile = Trim(Dialogue.lpstrFile)
OpenFile = Left(OpenFile, Len(OpenFile) - 1)
OpenFile = Replace(OpenFile, Chr(0), ";")
tOpenFile = Split(OpenFile, ";")
If UBound(tOpenFile) = 0 Then
nOpenFile = 1
ElseIf UBound(tOpenFile) = 1 Then
OpenFile = Replace(OpenFile, ";", "")
nOpenFile = 1
Else
nOpenFile = UBound(tOpenFile) - 1
End If
If Not WithPath Then
If InStr(1, OpenFile, ";") > 0 Then
OpenFile = Mid(OpenFile, InStr(1, OpenFile, ";") + 1)
Else
OpenFile = Mid(OpenFile, InStrRev(OpenFile, "") + 1)
End If
End If
End Function
Public Function SaveFile(Optional InitialFolder As String = "", _
Optional FileType As acOpenFileType = AllFiles _
) As String
SaveFile = ""
If InitialFolder = "" Then InitialFolder =
"I:TouusersMapsCatalogueX01"
ExtendChoose FileType
With Dialogue
.hwndOwner = Access.hWndAccessApp
.lStructSize = Len(Dialogue)
.lpstrFilter = strFiltre
.lpstrFile = Space(254)
.nMaxFile = 255
.lpstrFileTitle = Space(254)
.nMaxFileTitle = 255
.lpInitialFolder = InitialFolder
.lpstrTitle = "Sauvegarde d'un fichier"
.Flags = 6148
End With
RetVal = GetSaveFileName(Dialogue)
If RetVal >= 1 Then
SaveFile = Trim(Dialogue.lpstrFile)
SaveFile = Replace(SaveFile, Chr(0), "")
Else
SaveFile = ""
Exit Function
End If
End Function
Dans module d’importation :
Public Function Import() As Boolean
Dim SelectedFile As String
' Utilisation de rep déclaré en Optionnel
' et visualisation des fichiers textes
SelectedFile = OpenFile("C:Chemin", , , texte, NewFile:úlse)
'SelectedFile = OpenFile()
If Len(SelectedFile) > 0 Then
'MsgBox SelectedFile
'Adapter le nom de la table
DoCmd.TransferText acImportFixed, "Fichier", "Table", SelectedFile, True
End If
SelectedFile = OpenFile("C:Chemin", , , texte)
'SelectedFile = OpenFile()
If Len(SelectedFile) > 0 Then
'MsgBox SelectedFile
'Adapter le nom de la table
DoCmd.TransferText acImportFixed, "Fichier", "Table", SelectedFile, True
End If
End Function
J'avais eu la même demande dans le temps et un généreux contributeur m'avait donné ces codes qui si ils sont trés lourd dans leur structure fonctionnent trés bien :
Dans module global :
Option Compare Database Option Explicit
Public Enum Selection Mono_Sélection = 1 Multi_Sélection = 2 End Enum
Public Enum acOpenFileType AllFiles Image MSOffice MultiMedia Sound texte End Enum
Public Const OFN_AllowMultiSelect = &H200 Public Const OFN_CreatePrompt = &H2000 Public Const OFN_EnableHook = &H20 Public Const OFN_EnableTemplate = &H40 Public Const OFN_EnableTemplateHandle = &H80 Public Const OFN_EXPLORER = &H80000 Public Const OFN_ExtensionDifferent = &H400 Public Const OFN_FileMustExist = &H1000 Public Const OFN_HideReadOnly = &H4 Public Const OFN_LongNames = &H200000 Public Const OFN_NoChangeDir = &H8 Public Const OFN_NoDeReferenceLinks = &H100000 Public Const OFN_NoLongNames = &H40000 Public Const OFN_NoNetWorkButton = &H20000 Public Const OFN_NoReadOnlyReturn = &H8000 Public Const OFN_NoTestFileCreate = &H10000 Public Const OFN_NoValiDate = &H100 Public Const OFN_OverWritePrompt = &H2 Public Const OFN_PathMustExist = &H800 Public Const OFN_ReadOnly = &H1 Public Const OFN_ShareAware = &H4000 Public Const OFN_ShareFallThrough = 2 Public Const OFN_ShareNoWarn = 1 Public Const OFN_ShareWarn = 0 Public Const OFN_ShowHelp = &H10 Public Dialogue As OpenFileName Public strFiltre As String Public strFile As String Public strNomFile As String Public RetVal As Long Public tOpenFile As Variant Public nOpenFile As Long Public FileType As acOpenFileType
Public Type OpenFileName lStructSize As Long hwndOwner As Long Instance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustomFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpInitialFolder 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long Public Declare Function GetSaveFileName Lib "comdlg32.dll" _ Alias "GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
Public Function OpenFile( _ Optional InitialFolder As String = "d:", _ Optional MultiSelect As Selection = Mono_Sélection, _ Optional ModalWindow As Boolean = True, _ Optional FileType As acOpenFileType = texte, _ Optional KbBufferLength As Long = 4, _ Optional WithPath As Boolean = True, _ Optional NewFile As Boolean = True _ ) As String OpenFile = "" 'If InitialFolder = "" Then InitialFolder = "I:TouusersMapsCatalogueX01" Dim Id 'Id = OpenFile(, Multi_Sélection, True, texte, 12, False) 'Id = OpenFile(, Multi_Sélection, True, allfiles, 12, False) 'pour tous 'Id = OpenFile("CheminRepertoire", Multi_Sélection, True, allfiles, 12, False)
If KbBufferLength < 4 Or KbBufferLength > 63 Then KbBufferLength = 4 End If ExtendChoose FileType With Dialogue If ModalWindow Then .hwndOwner = Access.hWndAccessApp Else .hwndOwner = 0 End If .lStructSize = Len(Dialogue) .lpstrFilter = strFiltre .lpInitialFolder = InitialFolder 'Recherche du fichier précédent If Not NewFile Then .lpstrTitle = "Recherche du fichier ancien " Else 'Recherche du nouveau fichier .lpstrTitle = "Recherche du fichier nouveau " End If '.lpstrTitle = "Recherche du fichier nouveau " '& IIf(Not NewFile, "ancien", "") 'Indication Boite de dialogue du 2° fichier If MultiSelect = Mono_Sélection Then .lpstrFile = Space(254) .nMaxFile = 255 .lpstrFileTitle = Space(254) .nMaxFileTitle = 255 .Flags = 6148 Else .lpstrFile = Space((KbBufferLength * 4096) - 2) .nMaxFile = ((KbBufferLength * 4096) - 1) .lpstrFileTitle = Space((KbBufferLength * 4096) - 2) .nMaxFileTitle = ((KbBufferLength * 4096) - 1) .Flags = 6148 Or OFN_FileMustExist _ Or OFN_EXPLORER _ Or OFN_AllowMultiSelect End If End With RetVal = GetOpenFileName(Dialogue) If RetVal = 0 Then OpenFile = "" nOpenFile = 0 Exit Function End If OpenFile = Trim(Dialogue.lpstrFile) OpenFile = Left(OpenFile, Len(OpenFile) - 1) OpenFile = Replace(OpenFile, Chr(0), ";") tOpenFile = Split(OpenFile, ";") If UBound(tOpenFile) = 0 Then nOpenFile = 1 ElseIf UBound(tOpenFile) = 1 Then OpenFile = Replace(OpenFile, ";", "") nOpenFile = 1 Else nOpenFile = UBound(tOpenFile) - 1 End If If Not WithPath Then If InStr(1, OpenFile, ";") > 0 Then OpenFile = Mid(OpenFile, InStr(1, OpenFile, ";") + 1) Else OpenFile = Mid(OpenFile, InStrRev(OpenFile, "") + 1) End If End If End Function
Public Function SaveFile(Optional InitialFolder As String = "", _ Optional FileType As acOpenFileType = AllFiles _ ) As String SaveFile = "" If InitialFolder = "" Then InitialFolder = "I:TouusersMapsCatalogueX01" ExtendChoose FileType With Dialogue .hwndOwner = Access.hWndAccessApp .lStructSize = Len(Dialogue) .lpstrFilter = strFiltre .lpstrFile = Space(254) .nMaxFile = 255 .lpstrFileTitle = Space(254) .nMaxFileTitle = 255 .lpInitialFolder = InitialFolder .lpstrTitle = "Sauvegarde d'un fichier" .Flags = 6148 End With RetVal = GetSaveFileName(Dialogue) If RetVal >= 1 Then SaveFile = Trim(Dialogue.lpstrFile) SaveFile = Replace(SaveFile, Chr(0), "") Else SaveFile = "" Exit Function End If End Function
Dans module d’importation : Public Function Import() As Boolean Dim SelectedFile As String ' Utilisation de rep déclaré en Optionnel ' et visualisation des fichiers textes SelectedFile = OpenFile("C:Chemin", , , texte, NewFile:úlse) 'SelectedFile = OpenFile() If Len(SelectedFile) > 0 Then 'MsgBox SelectedFile 'Adapter le nom de la table DoCmd.TransferText acImportFixed, "Fichier", "Table", SelectedFile, True End If SelectedFile = OpenFile("C:Chemin", , , texte) 'SelectedFile = OpenFile() If Len(SelectedFile) > 0 Then 'MsgBox SelectedFile 'Adapter le nom de la table DoCmd.TransferText acImportFixed, "Fichier", "Table", SelectedFile, True End If End Function