Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien
de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau :
Private Sub Lien_Click()
getdir = SelectFolder(WithNetworkFolders)
If Len(getdir) = 0 Then Exit Sub 'user selected cancel
Lien1 = getdir
End Sub
Ouvrir le lien :
Private Sub lien _Click()
DoCmd.SetWarnings False
Dim Réponse As Variant
Dim Variable_string As String
Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True)
Réponse = OpenFileExtend(Variable_string, , OpExecute)
End Sub
_____________________________________________________________
Avec ces modules:
Option Compare Database
Option Explicit
Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA"
(ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As
Long) As Long
Public Enum TypeOpen
Hide = 0
Normal = 1
Minimized = 2
Maximized = 3
Restore = 9
End Enum
Public Enum OP
OpExecute = 1
OpPrint = 2
End Enum
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Function OpenFileExtend(FileName As String, Optional Window As TypeOpen =
Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long
Dim varTaskID As Variant
Dim stRet As String
lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print",
"open"), FileName, vbNullString, vbNullString, Window)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& FileName, 1)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Erreur: Pas assez de mémoire pour exécuter"
Case ERROR_FILE_NOT_FOUND:
stRet = "Erreur : FileName non trouvé"
Case ERROR_PATH_NOT_FOUND:
stRet = "Erreur : chemin non trouvé"
Case ERROR_BAD_FORMAT:
stRet = "Erreur : Type de FileName inconnu"
Case Else:
End Select
End If
OpenFileExtend = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
Option Compare Database
Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Enum Network
WithNetworkFolders = 0
WithoutNetworkFolders = 2
End Enum
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional
NetworkFolders As Network = WithNetworkFolders) As String
Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
If Folder = "" Then Folder = CurrentProject.path
With bi
.hOwner = hWndAccessApp
.lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf
& Folder
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders
End With
dwIList = SHBrowseForFolder(bi)
szPath = Folder & Space$(512 - Len(Folder))
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
SelectFolder = Left$(szPath, wPos - 1)
Else
SelectFolder = ""
End If
End Function
Function fFolderExist(DrivePath As String) As Boolean
If Dir(DrivePath, vbDirectory) <> "Lien1" Then
fFolderExist = True
Else
fFolderExist = False
End If
End Function
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
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 = "", Optional
MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean =
True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength
As Long = 4, Optional WithPath As Boolean = True) As String
OpenFile = ""
If InitialFolder = "" Then InitialFolder = CurrentProject.path
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
.lpstrTitle = "Recherche d'un 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 = CurrentProject.path
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
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
ze Titi
Salut Luis !
Pas bien compris la question... Pour stocker le lien, un simple glisser-déposer dans un contrôle dont le lien hypertexte est activé suffit. Pour le rouvrir, même principe, activer le lien hypertexte dans le contrôle, le lien est alors cliquable et ouvre ton navigateur préféré sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau : Private Sub Lien_Click() getdir = SelectFolder(WithNetworkFolders) If Len(getdir) = 0 Then Exit Sub 'user selected cancel Lien1 = getdir End Sub
Ouvrir le lien : Private Sub lien _Click() DoCmd.SetWarnings False Dim Réponse As Variant Dim Variable_string As String Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True) Réponse = OpenFileExtend(Variable_string, , OpExecute) End Sub _____________________________________________________________ Avec ces modules:
Option Compare Database Option Explicit Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Enum TypeOpen Hide = 0 Normal = 1 Minimized = 2 Maximized = 3 Restore = 9 End Enum Public Enum OP OpExecute = 1 OpPrint = 2 End Enum Private Const ERROR_SUCCESS = 32& Private Const ERROR_NO_ASSOC = 31& Private Const ERROR_OUT_OF_MEM = 0& Private Const ERROR_FILE_NOT_FOUND = 2& Private Const ERROR_PATH_NOT_FOUND = 3& Private Const ERROR_BAD_FORMAT = 11& Function OpenFileExtend(FileName As String, Optional Window As TypeOpen = Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long Dim varTaskID As Variant Dim stRet As String lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print", "open"), FileName, vbNullString, vbNullString, Window) If lRet > ERROR_SUCCESS Then stRet = vbNullString lRet = -1 Else Select Case lRet Case ERROR_NO_ASSOC: varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _ & FileName, 1) lRet = (varTaskID <> 0) Case ERROR_OUT_OF_MEM: stRet = "Erreur: Pas assez de mémoire pour exécuter" Case ERROR_FILE_NOT_FOUND: stRet = "Erreur : FileName non trouvé" Case ERROR_PATH_NOT_FOUND: stRet = "Erreur : chemin non trouvé" Case ERROR_BAD_FORMAT: stRet = "Erreur : Type de FileName inconnu" Case Else: End Select End If OpenFileExtend = lRet & _ IIf(stRet = "", vbNullString, ", " & stRet) End Function
Option Compare Database Option Explicit
Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Enum Network WithNetworkFolders = 0 WithoutNetworkFolders = 2 End Enum Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Const BIF_RETURNONLYFSDIRS = &H1 Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional NetworkFolders As Network = WithNetworkFolders) As String Dim x As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer If Folder = "" Then Folder = CurrentProject.path With bi .hOwner = hWndAccessApp .lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf & Folder .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders End With dwIList = SHBrowseForFolder(bi) szPath = Folder & Space$(512 - Len(Folder)) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) SelectFolder = Left$(szPath, wPos - 1) Else SelectFolder = "" End If End Function
Function fFolderExist(DrivePath As String) As Boolean If Dir(DrivePath, vbDirectory) <> "Lien1" Then fFolderExist = True Else fFolderExist = False End If End Function 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 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 = "", Optional MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean = True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String OpenFile = "" If InitialFolder = "" Then InitialFolder = CurrentProject.path 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 .lpstrTitle = "Recherche d'un 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 = CurrentProject.path 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
Merci pour votre aide. Luis
-- Cordialement, Ze Titi
Tout pour réussir avec Access : http://www.mpfa.info
Salut Luis !
Pas bien compris la question...
Pour stocker le lien, un simple glisser-déposer dans un contrôle dont
le lien hypertexte est activé suffit.
Pour le rouvrir, même principe, activer le lien hypertexte dans le
contrôle, le lien est alors cliquable et ouvre ton navigateur préféré
sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très
généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien
de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau :
Private Sub Lien_Click()
getdir = SelectFolder(WithNetworkFolders)
If Len(getdir) = 0 Then Exit Sub 'user selected cancel
Lien1 = getdir
End Sub
Ouvrir le lien :
Private Sub lien _Click()
DoCmd.SetWarnings False
Dim Réponse As Variant
Dim Variable_string As String
Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True)
Réponse = OpenFileExtend(Variable_string, , OpExecute)
End Sub
_____________________________________________________________
Avec ces modules:
Option Compare Database
Option Explicit
Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA"
(ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As
Long) As Long
Public Enum TypeOpen
Hide = 0
Normal = 1
Minimized = 2
Maximized = 3
Restore = 9
End Enum
Public Enum OP
OpExecute = 1
OpPrint = 2
End Enum
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Function OpenFileExtend(FileName As String, Optional Window As TypeOpen =
Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long
Dim varTaskID As Variant
Dim stRet As String
lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print",
"open"), FileName, vbNullString, vbNullString, Window)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& FileName, 1)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Erreur: Pas assez de mémoire pour exécuter"
Case ERROR_FILE_NOT_FOUND:
stRet = "Erreur : FileName non trouvé"
Case ERROR_PATH_NOT_FOUND:
stRet = "Erreur : chemin non trouvé"
Case ERROR_BAD_FORMAT:
stRet = "Erreur : Type de FileName inconnu"
Case Else:
End Select
End If
OpenFileExtend = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
Option Compare Database
Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Enum Network
WithNetworkFolders = 0
WithoutNetworkFolders = 2
End Enum
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional
NetworkFolders As Network = WithNetworkFolders) As String
Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
If Folder = "" Then Folder = CurrentProject.path
With bi
.hOwner = hWndAccessApp
.lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf
& Folder
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders
End With
dwIList = SHBrowseForFolder(bi)
szPath = Folder & Space$(512 - Len(Folder))
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
SelectFolder = Left$(szPath, wPos - 1)
Else
SelectFolder = ""
End If
End Function
Function fFolderExist(DrivePath As String) As Boolean
If Dir(DrivePath, vbDirectory) <> "Lien1" Then
fFolderExist = True
Else
fFolderExist = False
End If
End Function
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
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 = "", Optional
MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean =
True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength
As Long = 4, Optional WithPath As Boolean = True) As String
OpenFile = ""
If InitialFolder = "" Then InitialFolder = CurrentProject.path
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
.lpstrTitle = "Recherche d'un 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 = CurrentProject.path
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
Merci pour votre aide.
Luis
--
Cordialement,
Ze Titi
Tout pour réussir avec Access :
http://www.mpfa.info
Pas bien compris la question... Pour stocker le lien, un simple glisser-déposer dans un contrôle dont le lien hypertexte est activé suffit. Pour le rouvrir, même principe, activer le lien hypertexte dans le contrôle, le lien est alors cliquable et ouvre ton navigateur préféré sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau : Private Sub Lien_Click() getdir = SelectFolder(WithNetworkFolders) If Len(getdir) = 0 Then Exit Sub 'user selected cancel Lien1 = getdir End Sub
Ouvrir le lien : Private Sub lien _Click() DoCmd.SetWarnings False Dim Réponse As Variant Dim Variable_string As String Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True) Réponse = OpenFileExtend(Variable_string, , OpExecute) End Sub _____________________________________________________________ Avec ces modules:
Option Compare Database Option Explicit Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Enum TypeOpen Hide = 0 Normal = 1 Minimized = 2 Maximized = 3 Restore = 9 End Enum Public Enum OP OpExecute = 1 OpPrint = 2 End Enum Private Const ERROR_SUCCESS = 32& Private Const ERROR_NO_ASSOC = 31& Private Const ERROR_OUT_OF_MEM = 0& Private Const ERROR_FILE_NOT_FOUND = 2& Private Const ERROR_PATH_NOT_FOUND = 3& Private Const ERROR_BAD_FORMAT = 11& Function OpenFileExtend(FileName As String, Optional Window As TypeOpen = Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long Dim varTaskID As Variant Dim stRet As String lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print", "open"), FileName, vbNullString, vbNullString, Window) If lRet > ERROR_SUCCESS Then stRet = vbNullString lRet = -1 Else Select Case lRet Case ERROR_NO_ASSOC: varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _ & FileName, 1) lRet = (varTaskID <> 0) Case ERROR_OUT_OF_MEM: stRet = "Erreur: Pas assez de mémoire pour exécuter" Case ERROR_FILE_NOT_FOUND: stRet = "Erreur : FileName non trouvé" Case ERROR_PATH_NOT_FOUND: stRet = "Erreur : chemin non trouvé" Case ERROR_BAD_FORMAT: stRet = "Erreur : Type de FileName inconnu" Case Else: End Select End If OpenFileExtend = lRet & _ IIf(stRet = "", vbNullString, ", " & stRet) End Function
Option Compare Database Option Explicit
Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Enum Network WithNetworkFolders = 0 WithoutNetworkFolders = 2 End Enum Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Const BIF_RETURNONLYFSDIRS = &H1 Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional NetworkFolders As Network = WithNetworkFolders) As String Dim x As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer If Folder = "" Then Folder = CurrentProject.path With bi .hOwner = hWndAccessApp .lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf & Folder .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders End With dwIList = SHBrowseForFolder(bi) szPath = Folder & Space$(512 - Len(Folder)) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) SelectFolder = Left$(szPath, wPos - 1) Else SelectFolder = "" End If End Function
Function fFolderExist(DrivePath As String) As Boolean If Dir(DrivePath, vbDirectory) <> "Lien1" Then fFolderExist = True Else fFolderExist = False End If End Function 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 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 = "", Optional MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean = True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String OpenFile = "" If InitialFolder = "" Then InitialFolder = CurrentProject.path 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 .lpstrTitle = "Recherche d'un 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 = CurrentProject.path 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
Merci pour votre aide. Luis
-- Cordialement, Ze Titi
Tout pour réussir avec Access : http://www.mpfa.info
Luis
Bonjour, Ce que je veux faire : Lorsque j’ai une page internet ouverte qui concerne par exemple le titulaire du formulaire, sur un clic de bouton enregistrer l’adresse de cette page internet dans le champ ‘Lien_Internet’ de la table et pouvoir lancer avec un autre bouton cette page depuis le formulaire. Merci. Luis
Salut Luis !
Pas bien compris la question... Pour stocker le lien, un simple glisser-déposer dans un contrôle dont le lien hypertexte est activé suffit. Pour le rouvrir, même principe, activer le lien hypertexte dans le contrôle, le lien est alors cliquable et ouvre ton navigateur préféré sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau : Private Sub Lien_Click() getdir = SelectFolder(WithNetworkFolders) If Len(getdir) = 0 Then Exit Sub 'user selected cancel Lien1 = getdir End Sub
Ouvrir le lien : Private Sub lien _Click() DoCmd.SetWarnings False Dim Réponse As Variant Dim Variable_string As String Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True) Réponse = OpenFileExtend(Variable_string, , OpExecute) End Sub _____________________________________________________________ Avec ces modules:
Option Compare Database Option Explicit Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Enum TypeOpen Hide = 0 Normal = 1 Minimized = 2 Maximized = 3 Restore = 9 End Enum Public Enum OP OpExecute = 1 OpPrint = 2 End Enum Private Const ERROR_SUCCESS = 32& Private Const ERROR_NO_ASSOC = 31& Private Const ERROR_OUT_OF_MEM = 0& Private Const ERROR_FILE_NOT_FOUND = 2& Private Const ERROR_PATH_NOT_FOUND = 3& Private Const ERROR_BAD_FORMAT = 11& Function OpenFileExtend(FileName As String, Optional Window As TypeOpen = Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long Dim varTaskID As Variant Dim stRet As String lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print", "open"), FileName, vbNullString, vbNullString, Window) If lRet > ERROR_SUCCESS Then stRet = vbNullString lRet = -1 Else Select Case lRet Case ERROR_NO_ASSOC: varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _ & FileName, 1) lRet = (varTaskID <> 0) Case ERROR_OUT_OF_MEM: stRet = "Erreur: Pas assez de mémoire pour exécuter" Case ERROR_FILE_NOT_FOUND: stRet = "Erreur : FileName non trouvé" Case ERROR_PATH_NOT_FOUND: stRet = "Erreur : chemin non trouvé" Case ERROR_BAD_FORMAT: stRet = "Erreur : Type de FileName inconnu" Case Else: End Select End If OpenFileExtend = lRet & _ IIf(stRet = "", vbNullString, ", " & stRet) End Function
Option Compare Database Option Explicit
Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Enum Network WithNetworkFolders = 0 WithoutNetworkFolders = 2 End Enum Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Const BIF_RETURNONLYFSDIRS = &H1 Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional NetworkFolders As Network = WithNetworkFolders) As String Dim x As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer If Folder = "" Then Folder = CurrentProject.path With bi .hOwner = hWndAccessApp .lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf & Folder .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders End With dwIList = SHBrowseForFolder(bi) szPath = Folder & Space$(512 - Len(Folder)) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) SelectFolder = Left$(szPath, wPos - 1) Else SelectFolder = "" End If End Function
Function fFolderExist(DrivePath As String) As Boolean If Dir(DrivePath, vbDirectory) <> "Lien1" Then fFolderExist = True Else fFolderExist = False End If End Function 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 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 = "", Optional MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean = True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String OpenFile = "" If InitialFolder = "" Then InitialFolder = CurrentProject.path 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 .lpstrTitle = "Recherche d'un 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)
Bonjour,
Ce que je veux faire :
Lorsque j’ai une page internet ouverte qui concerne par exemple le titulaire
du formulaire, sur un clic de bouton enregistrer l’adresse de cette page
internet dans le champ ‘Lien_Internet’ de la table et pouvoir lancer avec un
autre bouton cette page depuis le formulaire.
Merci.
Luis
Salut Luis !
Pas bien compris la question...
Pour stocker le lien, un simple glisser-déposer dans un contrôle dont
le lien hypertexte est activé suffit.
Pour le rouvrir, même principe, activer le lien hypertexte dans le
contrôle, le lien est alors cliquable et ouvre ton navigateur préféré
sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très
généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien
de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau :
Private Sub Lien_Click()
getdir = SelectFolder(WithNetworkFolders)
If Len(getdir) = 0 Then Exit Sub 'user selected cancel
Lien1 = getdir
End Sub
Ouvrir le lien :
Private Sub lien _Click()
DoCmd.SetWarnings False
Dim Réponse As Variant
Dim Variable_string As String
Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True)
Réponse = OpenFileExtend(Variable_string, , OpExecute)
End Sub
_____________________________________________________________
Avec ces modules:
Option Compare Database
Option Explicit
Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA"
(ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As
Long) As Long
Public Enum TypeOpen
Hide = 0
Normal = 1
Minimized = 2
Maximized = 3
Restore = 9
End Enum
Public Enum OP
OpExecute = 1
OpPrint = 2
End Enum
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Function OpenFileExtend(FileName As String, Optional Window As TypeOpen =
Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long
Dim varTaskID As Variant
Dim stRet As String
lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print",
"open"), FileName, vbNullString, vbNullString, Window)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& FileName, 1)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Erreur: Pas assez de mémoire pour exécuter"
Case ERROR_FILE_NOT_FOUND:
stRet = "Erreur : FileName non trouvé"
Case ERROR_PATH_NOT_FOUND:
stRet = "Erreur : chemin non trouvé"
Case ERROR_BAD_FORMAT:
stRet = "Erreur : Type de FileName inconnu"
Case Else:
End Select
End If
OpenFileExtend = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
Option Compare Database
Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Enum Network
WithNetworkFolders = 0
WithoutNetworkFolders = 2
End Enum
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional
NetworkFolders As Network = WithNetworkFolders) As String
Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
If Folder = "" Then Folder = CurrentProject.path
With bi
.hOwner = hWndAccessApp
.lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf
& Folder
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders
End With
dwIList = SHBrowseForFolder(bi)
szPath = Folder & Space$(512 - Len(Folder))
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
SelectFolder = Left$(szPath, wPos - 1)
Else
SelectFolder = ""
End If
End Function
Function fFolderExist(DrivePath As String) As Boolean
If Dir(DrivePath, vbDirectory) <> "Lien1" Then
fFolderExist = True
Else
fFolderExist = False
End If
End Function
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
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 = "", Optional
MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean =
True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength
As Long = 4, Optional WithPath As Boolean = True) As String
OpenFile = ""
If InitialFolder = "" Then InitialFolder = CurrentProject.path
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
.lpstrTitle = "Recherche d'un 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)
Bonjour, Ce que je veux faire : Lorsque j’ai une page internet ouverte qui concerne par exemple le titulaire du formulaire, sur un clic de bouton enregistrer l’adresse de cette page internet dans le champ ‘Lien_Internet’ de la table et pouvoir lancer avec un autre bouton cette page depuis le formulaire. Merci. Luis
Salut Luis !
Pas bien compris la question... Pour stocker le lien, un simple glisser-déposer dans un contrôle dont le lien hypertexte est activé suffit. Pour le rouvrir, même principe, activer le lien hypertexte dans le contrôle, le lien est alors cliquable et ouvre ton navigateur préféré sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau : Private Sub Lien_Click() getdir = SelectFolder(WithNetworkFolders) If Len(getdir) = 0 Then Exit Sub 'user selected cancel Lien1 = getdir End Sub
Ouvrir le lien : Private Sub lien _Click() DoCmd.SetWarnings False Dim Réponse As Variant Dim Variable_string As String Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True) Réponse = OpenFileExtend(Variable_string, , OpExecute) End Sub _____________________________________________________________ Avec ces modules:
Option Compare Database Option Explicit Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Enum TypeOpen Hide = 0 Normal = 1 Minimized = 2 Maximized = 3 Restore = 9 End Enum Public Enum OP OpExecute = 1 OpPrint = 2 End Enum Private Const ERROR_SUCCESS = 32& Private Const ERROR_NO_ASSOC = 31& Private Const ERROR_OUT_OF_MEM = 0& Private Const ERROR_FILE_NOT_FOUND = 2& Private Const ERROR_PATH_NOT_FOUND = 3& Private Const ERROR_BAD_FORMAT = 11& Function OpenFileExtend(FileName As String, Optional Window As TypeOpen = Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long Dim varTaskID As Variant Dim stRet As String lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print", "open"), FileName, vbNullString, vbNullString, Window) If lRet > ERROR_SUCCESS Then stRet = vbNullString lRet = -1 Else Select Case lRet Case ERROR_NO_ASSOC: varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _ & FileName, 1) lRet = (varTaskID <> 0) Case ERROR_OUT_OF_MEM: stRet = "Erreur: Pas assez de mémoire pour exécuter" Case ERROR_FILE_NOT_FOUND: stRet = "Erreur : FileName non trouvé" Case ERROR_PATH_NOT_FOUND: stRet = "Erreur : chemin non trouvé" Case ERROR_BAD_FORMAT: stRet = "Erreur : Type de FileName inconnu" Case Else: End Select End If OpenFileExtend = lRet & _ IIf(stRet = "", vbNullString, ", " & stRet) End Function
Option Compare Database Option Explicit
Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Enum Network WithNetworkFolders = 0 WithoutNetworkFolders = 2 End Enum Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Const BIF_RETURNONLYFSDIRS = &H1 Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional NetworkFolders As Network = WithNetworkFolders) As String Dim x As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer If Folder = "" Then Folder = CurrentProject.path With bi .hOwner = hWndAccessApp .lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf & Folder .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders End With dwIList = SHBrowseForFolder(bi) szPath = Folder & Space$(512 - Len(Folder)) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) SelectFolder = Left$(szPath, wPos - 1) Else SelectFolder = "" End If End Function
Function fFolderExist(DrivePath As String) As Boolean If Dir(DrivePath, vbDirectory) <> "Lien1" Then fFolderExist = True Else fFolderExist = False End If End Function 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 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 = "", Optional MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean = True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String OpenFile = "" If InitialFolder = "" Then InitialFolder = CurrentProject.path 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 .lpstrTitle = "Recherche d'un 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)
ze Titi
Hello Luis !
Concernant le deuxième point, ce que je t'ai dit reste valable, même pas besoin de bouton. Concernant l'enregistrement, je ne sais pas. L'astuce que je t'ai donnée utilise le drag-n-drop, pas besoin de bouton ni de code. Maintenant, si cela ne te convient pas, attends les idées des costauds !
En ce jour mémorable du vendredi 02/03/2007, tu as entrepris la lourde tâche de taper sur ton clavier :
Bonjour, Ce que je veux faire : Lorsque j’ai une page internet ouverte qui concerne par exemple le titulaire du formulaire, sur un clic de bouton enregistrer l’adresse de cette page internet dans le champ ‘Lien_Internet’ de la table et pouvoir lancer avec un autre bouton cette page depuis le formulaire. Merci. Luis
Salut Luis !
Pas bien compris la question... Pour stocker le lien, un simple glisser-déposer dans un contrôle dont le lien hypertexte est activé suffit. Pour le rouvrir, même principe, activer le lien hypertexte dans le contrôle, le lien est alors cliquable et ouvre ton navigateur préféré sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau : Private Sub Lien_Click() getdir = SelectFolder(WithNetworkFolders) If Len(getdir) = 0 Then Exit Sub 'user selected cancel Lien1 = getdir End Sub
Ouvrir le lien : Private Sub lien _Click() DoCmd.SetWarnings False Dim Réponse As Variant Dim Variable_string As String Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True) Réponse = OpenFileExtend(Variable_string, , OpExecute) End Sub _____________________________________________________________ Avec ces modules:
Option Compare Database Option Explicit Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Enum TypeOpen Hide = 0 Normal = 1 Minimized = 2 Maximized = 3 Restore = 9 End Enum Public Enum OP OpExecute = 1 OpPrint = 2 End Enum Private Const ERROR_SUCCESS = 32& Private Const ERROR_NO_ASSOC = 31& Private Const ERROR_OUT_OF_MEM = 0& Private Const ERROR_FILE_NOT_FOUND = 2& Private Const ERROR_PATH_NOT_FOUND = 3& Private Const ERROR_BAD_FORMAT = 11& Function OpenFileExtend(FileName As String, Optional Window As TypeOpen = Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long Dim varTaskID As Variant Dim stRet As String lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print", "open"), FileName, vbNullString, vbNullString, Window) If lRet > ERROR_SUCCESS Then stRet = vbNullString lRet = -1 Else Select Case lRet Case ERROR_NO_ASSOC: varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _ & FileName, 1) lRet = (varTaskID <> 0) Case ERROR_OUT_OF_MEM: stRet = "Erreur: Pas assez de mémoire pour exécuter" Case ERROR_FILE_NOT_FOUND: stRet = "Erreur : FileName non trouvé" Case ERROR_PATH_NOT_FOUND: stRet = "Erreur : chemin non trouvé" Case ERROR_BAD_FORMAT: stRet = "Erreur : Type de FileName inconnu" Case Else: End Select End If OpenFileExtend = lRet & _ IIf(stRet = "", vbNullString, ", " & stRet) End Function
Option Compare Database Option Explicit
Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Enum Network WithNetworkFolders = 0 WithoutNetworkFolders = 2 End Enum Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Const BIF_RETURNONLYFSDIRS = &H1 Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional NetworkFolders As Network = WithNetworkFolders) As String Dim x As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer If Folder = "" Then Folder = CurrentProject.path With bi .hOwner = hWndAccessApp .lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf & Folder .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders End With dwIList = SHBrowseForFolder(bi) szPath = Folder & Space$(512 - Len(Folder)) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) SelectFolder = Left$(szPath, wPos - 1) Else SelectFolder = "" End If End Function
Function fFolderExist(DrivePath As String) As Boolean If Dir(DrivePath, vbDirectory) <> "Lien1" Then fFolderExist = True Else fFolderExist = False End If End Function 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 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 = "", Optional MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean = True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String OpenFile = "" If InitialFolder = "" Then InitialFolder = CurrentProject.path 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 .lpstrTitle = "Recherche d'un 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)
-- Cordialement, Ze Titi
Tout pour réussir avec Access : http://www.mpfa.info
Hello Luis !
Concernant le deuxième point, ce que je t'ai dit reste valable, même
pas besoin de bouton.
Concernant l'enregistrement, je ne sais pas. L'astuce que je t'ai
donnée utilise le drag-n-drop, pas besoin de bouton ni de code.
Maintenant, si cela ne te convient pas, attends les idées des costauds
!
En ce jour mémorable du vendredi 02/03/2007, tu as entrepris la lourde
tâche de taper sur ton clavier :
Bonjour,
Ce que je veux faire :
Lorsque j’ai une page internet ouverte qui concerne par exemple le titulaire
du formulaire, sur un clic de bouton enregistrer l’adresse de cette page
internet dans le champ ‘Lien_Internet’ de la table et pouvoir lancer avec un
autre bouton cette page depuis le formulaire.
Merci.
Luis
Salut Luis !
Pas bien compris la question...
Pour stocker le lien, un simple glisser-déposer dans un contrôle dont
le lien hypertexte est activé suffit.
Pour le rouvrir, même principe, activer le lien hypertexte dans le
contrôle, le lien est alors cliquable et ouvre ton navigateur préféré
sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très
généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le
lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau :
Private Sub Lien_Click()
getdir = SelectFolder(WithNetworkFolders)
If Len(getdir) = 0 Then Exit Sub 'user selected cancel
Lien1 = getdir
End Sub
Ouvrir le lien :
Private Sub lien _Click()
DoCmd.SetWarnings False
Dim Réponse As Variant
Dim Variable_string As String
Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12,
True) Réponse = OpenFileExtend(Variable_string, , OpExecute)
End Sub
_____________________________________________________________
Avec ces modules:
Option Compare Database
Option Explicit
Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA"
(ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd
As Long) As Long
Public Enum TypeOpen
Hide = 0
Normal = 1
Minimized = 2
Maximized = 3
Restore = 9
End Enum
Public Enum OP
OpExecute = 1
OpPrint = 2
End Enum
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Function OpenFileExtend(FileName As String, Optional Window As TypeOpen =
Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long
Dim varTaskID As Variant
Dim stRet As String
lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print",
"open"), FileName, vbNullString, vbNullString, Window)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL "
_ & FileName, 1)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Erreur: Pas assez de mémoire pour exécuter"
Case ERROR_FILE_NOT_FOUND:
stRet = "Erreur : FileName non trouvé"
Case ERROR_PATH_NOT_FOUND:
stRet = "Erreur : chemin non trouvé"
Case ERROR_BAD_FORMAT:
stRet = "Erreur : Type de FileName inconnu"
Case Else:
End Select
End If
OpenFileExtend = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
Option Compare Database
Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Enum Network
WithNetworkFolders = 0
WithoutNetworkFolders = 2
End Enum
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As
Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional
NetworkFolders As Network = WithNetworkFolders) As String
Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
If Folder = "" Then Folder = CurrentProject.path
With bi
.hOwner = hWndAccessApp
.lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" &
vbCrLf & Folder
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders
End With
dwIList = SHBrowseForFolder(bi)
szPath = Folder & Space$(512 - Len(Folder))
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
SelectFolder = Left$(szPath, wPos - 1)
Else
SelectFolder = ""
End If
End Function
Function fFolderExist(DrivePath As String) As Boolean
If Dir(DrivePath, vbDirectory) <> "Lien1" Then
fFolderExist = True
Else
fFolderExist = False
End If
End Function
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
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 = "", Optional
MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean
= True, Optional FileType As acOpenFileType = MSOffice, Optional
KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String
OpenFile = ""
If InitialFolder = "" Then InitialFolder = CurrentProject.path
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
.lpstrTitle = "Recherche d'un 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)
--
Cordialement,
Ze Titi
Tout pour réussir avec Access :
http://www.mpfa.info
Concernant le deuxième point, ce que je t'ai dit reste valable, même pas besoin de bouton. Concernant l'enregistrement, je ne sais pas. L'astuce que je t'ai donnée utilise le drag-n-drop, pas besoin de bouton ni de code. Maintenant, si cela ne te convient pas, attends les idées des costauds !
En ce jour mémorable du vendredi 02/03/2007, tu as entrepris la lourde tâche de taper sur ton clavier :
Bonjour, Ce que je veux faire : Lorsque j’ai une page internet ouverte qui concerne par exemple le titulaire du formulaire, sur un clic de bouton enregistrer l’adresse de cette page internet dans le champ ‘Lien_Internet’ de la table et pouvoir lancer avec un autre bouton cette page depuis le formulaire. Merci. Luis
Salut Luis !
Pas bien compris la question... Pour stocker le lien, un simple glisser-déposer dans un contrôle dont le lien hypertexte est activé suffit. Pour le rouvrir, même principe, activer le lien hypertexte dans le contrôle, le lien est alors cliquable et ouvre ton navigateur préféré sur la page sélectionnée.
En ce jour exceptionnel du vendredi 02/03/2007, tu nous as très généreusement gratifié du message suivant:
Comment faire pour créer un lien sur internet, c'est-à-dire de copier le lien de la page ouverte sur Internet et ensuite l’ouvrir ?
Pour les liens sur le réseau interne j’utilise ça :
Créer le lien sur le réseau : Private Sub Lien_Click() getdir = SelectFolder(WithNetworkFolders) If Len(getdir) = 0 Then Exit Sub 'user selected cancel Lien1 = getdir End Sub
Ouvrir le lien : Private Sub lien _Click() DoCmd.SetWarnings False Dim Réponse As Variant Dim Variable_string As String Variable_string = OpenFile(Lien1, Multi_Sélection, True, MSOffice, 12, True) Réponse = OpenFileExtend(Variable_string, , OpExecute) End Sub _____________________________________________________________ Avec ces modules:
Option Compare Database Option Explicit Private Declare Function ShellExec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Enum TypeOpen Hide = 0 Normal = 1 Minimized = 2 Maximized = 3 Restore = 9 End Enum Public Enum OP OpExecute = 1 OpPrint = 2 End Enum Private Const ERROR_SUCCESS = 32& Private Const ERROR_NO_ASSOC = 31& Private Const ERROR_OUT_OF_MEM = 0& Private Const ERROR_FILE_NOT_FOUND = 2& Private Const ERROR_PATH_NOT_FOUND = 3& Private Const ERROR_BAD_FORMAT = 11& Function OpenFileExtend(FileName As String, Optional Window As TypeOpen = Minimized, Optional Operation As OP = OpExecute) As Variant
Dim lRet As Long Dim varTaskID As Variant Dim stRet As String lRet = ShellExec(hWndAccessApp, IIf(Operation = OpPrint, "print", "open"), FileName, vbNullString, vbNullString, Window) If lRet > ERROR_SUCCESS Then stRet = vbNullString lRet = -1 Else Select Case lRet Case ERROR_NO_ASSOC: varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _ & FileName, 1) lRet = (varTaskID <> 0) Case ERROR_OUT_OF_MEM: stRet = "Erreur: Pas assez de mémoire pour exécuter" Case ERROR_FILE_NOT_FOUND: stRet = "Erreur : FileName non trouvé" Case ERROR_PATH_NOT_FOUND: stRet = "Erreur : chemin non trouvé" Case ERROR_BAD_FORMAT: stRet = "Erreur : Type de FileName inconnu" Case Else: End Select End If OpenFileExtend = lRet & _ IIf(stRet = "", vbNullString, ", " & stRet) End Function
Option Compare Database Option Explicit
Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Enum Network WithNetworkFolders = 0 WithoutNetworkFolders = 2 End Enum Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Const BIF_RETURNONLYFSDIRS = &H1 Const BIF_USENEWUI = &H40
Public Function SelectFolder(Optional Folder As String = "", Optional NetworkFolders As Network = WithNetworkFolders) As String Dim x As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer If Folder = "" Then Folder = CurrentProject.path With bi .hOwner = hWndAccessApp .lpszTitle = "Sélectionnez votre dossier et cliquez sur OK" & vbCrLf & Folder .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or NetworkFolders End With dwIList = SHBrowseForFolder(bi) szPath = Folder & Space$(512 - Len(Folder)) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) SelectFolder = Left$(szPath, wPos - 1) Else SelectFolder = "" End If End Function
Function fFolderExist(DrivePath As String) As Boolean If Dir(DrivePath, vbDirectory) <> "Lien1" Then fFolderExist = True Else fFolderExist = False End If End Function 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 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 = "", Optional MultiSelect As Selection = Mono_Sélection, Optional ModalWindow As Boolean = True, Optional FileType As acOpenFileType = MSOffice, Optional KbBufferLength As Long = 4, Optional WithPath As Boolean = True) As String OpenFile = "" If InitialFolder = "" Then InitialFolder = CurrentProject.path 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 .lpstrTitle = "Recherche d'un 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)
-- Cordialement, Ze Titi
Tout pour réussir avec Access : http://www.mpfa.info
