Créer et ouvrir lien sur page internet

Le
Luis
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

Private Sub ExtendChoose(FileType As acOpenFileType)
Select Case FileType
Case allfiles
strFiltre = "Tous les fichiers" & Chr$(0) & "*.*"
Case Image
strFiltre = _
"Fichiers Jpg" & Chr$(0) & "*.jpg;*.jpeg" & Chr$(0) & _
"Fichiers Bmp" & Chr$(0) & "*.bmp" & Chr$(0) & _
"Fichiers Wmf" & Chr$(0) & "*.wmf" & Chr$(0) & _
"Fichiers Tif" & Chr$(0) & "*.tif" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"

Case MSOffice
strFiltre = _
"Tous les fichiers" & Chr$(0) & "*.*" & Chr$(0) & _
"Fichiers Word" & Chr$(0) & "*.doc;*txt" & Chr$(0) & _
"Fichiers Excel" & Chr$(0) & "*.xls" & Chr$(0) & _
"Fichiers Access" & Chr$(0) & "*.mdb;*.mde"

Case MultiMedia
strFiltre = _
"Fichiers Mpg" & Chr$(0) & "*.mpg;*.mpeg" & Chr$(0) & _
"Fichiers Avi" & Chr$(0) & "*.avi" & Chr$(0) & _
"Fichiers Wmv" & Chr$(0) & "*.wmv" & Chr$(0) & _
"Fichiers Asx" & Chr$(0) & "*.asx" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
Case Sound
strFiltre = _
"Fichiers Mp3" & Chr$(0) & "*.mp3;*.mpc" & Chr$(0) & _
"Fichiers Wav" & Chr$(0) & "*.wav" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
End Select
End Sub

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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
ze Titi
Le #6196931
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

Private Sub ExtendChoose(FileType As acOpenFileType)
Select Case FileType
Case allfiles
strFiltre = "Tous les fichiers" & Chr$(0) & "*.*"
Case Image
strFiltre = _
"Fichiers Jpg" & Chr$(0) & "*.jpg;*.jpeg" & Chr$(0) & _
"Fichiers Bmp" & Chr$(0) & "*.bmp" & Chr$(0) & _
"Fichiers Wmf" & Chr$(0) & "*.wmf" & Chr$(0) & _
"Fichiers Tif" & Chr$(0) & "*.tif" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"

Case MSOffice
strFiltre = _
"Tous les fichiers" & Chr$(0) & "*.*" & Chr$(0) & _
"Fichiers Word" & Chr$(0) & "*.doc;*txt" & Chr$(0) & _
"Fichiers Excel" & Chr$(0) & "*.xls" & Chr$(0) & _
"Fichiers Access" & Chr$(0) & "*.mdb;*.mde"

Case MultiMedia
strFiltre = _
"Fichiers Mpg" & Chr$(0) & "*.mpg;*.mpeg" & Chr$(0) & _
"Fichiers Avi" & Chr$(0) & "*.avi" & Chr$(0) & _
"Fichiers Wmv" & Chr$(0) & "*.wmv" & Chr$(0) & _
"Fichiers Asx" & Chr$(0) & "*.asx" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
Case Sound
strFiltre = _
"Fichiers Mp3" & Chr$(0) & "*.mp3;*.mpc" & Chr$(0) & _
"Fichiers Wav" & Chr$(0) & "*.wav" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
End Select
End Sub

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
Le #6196901
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

Private Sub ExtendChoose(FileType As acOpenFileType)
Select Case FileType
Case allfiles
strFiltre = "Tous les fichiers" & Chr$(0) & "*.*"
Case Image
strFiltre = _
"Fichiers Jpg" & Chr$(0) & "*.jpg;*.jpeg" & Chr$(0) & _
"Fichiers Bmp" & Chr$(0) & "*.bmp" & Chr$(0) & _
"Fichiers Wmf" & Chr$(0) & "*.wmf" & Chr$(0) & _
"Fichiers Tif" & Chr$(0) & "*.tif" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"

Case MSOffice
strFiltre = _
"Tous les fichiers" & Chr$(0) & "*.*" & Chr$(0) & _
"Fichiers Word" & Chr$(0) & "*.doc;*txt" & Chr$(0) & _
"Fichiers Excel" & Chr$(0) & "*.xls" & Chr$(0) & _
"Fichiers Access" & Chr$(0) & "*.mdb;*.mde"

Case MultiMedia
strFiltre = _
"Fichiers Mpg" & Chr$(0) & "*.mpg;*.mpeg" & Chr$(0) & _
"Fichiers Avi" & Chr$(0) & "*.avi" & Chr$(0) & _
"Fichiers Wmv" & Chr$(0) & "*.wmv" & Chr$(0) & _
"Fichiers Asx" & Chr$(0) & "*.asx" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
Case Sound
strFiltre = _
"Fichiers Mp3" & Chr$(0) & "*.mp3;*.mpc" & Chr$(0) & _
"Fichiers Wav" & Chr$(0) & "*.wav" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
End Select
End Sub

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
Le #6196891
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

Private Sub ExtendChoose(FileType As acOpenFileType)
Select Case FileType
Case allfiles
strFiltre = "Tous les fichiers" & Chr$(0) & "*.*"
Case Image
strFiltre = _
"Fichiers Jpg" & Chr$(0) & "*.jpg;*.jpeg" & Chr$(0) & _
"Fichiers Bmp" & Chr$(0) & "*.bmp" & Chr$(0) & _
"Fichiers Wmf" & Chr$(0) & "*.wmf" & Chr$(0) & _
"Fichiers Tif" & Chr$(0) & "*.tif" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"

Case MSOffice
strFiltre = _
"Tous les fichiers" & Chr$(0) & "*.*" & Chr$(0) & _
"Fichiers Word" & Chr$(0) & "*.doc;*txt" & Chr$(0) & _
"Fichiers Excel" & Chr$(0) & "*.xls" & Chr$(0) & _
"Fichiers Access" & Chr$(0) & "*.mdb;*.mde"

Case MultiMedia
strFiltre = _
"Fichiers Mpg" & Chr$(0) & "*.mpg;*.mpeg" & Chr$(0) & _
"Fichiers Avi" & Chr$(0) & "*.avi" & Chr$(0) & _
"Fichiers Wmv" & Chr$(0) & "*.wmv" & Chr$(0) & _
"Fichiers Asx" & Chr$(0) & "*.asx" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
Case Sound
strFiltre = _
"Fichiers Mp3" & Chr$(0) & "*.mp3;*.mpc" & Chr$(0) & _
"Fichiers Wav" & Chr$(0) & "*.wav" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"
End Select
End Sub

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



Publicité
Poster une réponse
Anonyme