1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
| Sub ExportAvecLiensHyptxt()
Dim sObjToExport As String, sExportToFile As String
Dim xlApp As Excel.Application, bQuitXl As Boolean
Dim xlWbk As Excel.Workbook, xlSht As Excel.Worksheet
Dim rgCell As Excel.Range, rgHdrCell As Excel.Range
Dim lRowMax As Long, lRow As Long, lPos As Long
Dim sText As String, sDispl As String, sAddr As String
' Table à exporter
sObjToExport = "tblLiensFAQ"
' Fichier dans lequel exporter
sExportToFile = CurrentProject.Path & "\" & "Liens.xls"
' On supprime le fichier s'il existe
If Len(Dir(sExportToFile, vbNormal)) > 0 Then Kill sExportToFile
' Export dans fichier Excel
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
sObjToExport, sExportToFile, True
' Ouvrir Excel
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo 0
If xlApp Is Nothing Then
Set xlApp = New Excel.Application
bQuitXl = True
End If
' Ouvre le classeur
Set xlWbk = xlApp.Workbooks.Open(sExportToFile)
' référence la feuille active
Set xlSht = xlWbk.ActiveSheet
' Recherche la colonne "LienHyptxt"
Set rgHdrCell = xlSht.Rows(1).Find("LienHyptxt", , xlValues, xlWhole)
If Not (rgHdrCell Is Nothing) Then
' Dernière ligne dans la feuille
lRowMax = xlSht.Cells.SpecialCells(xlCellTypeLastCell).Row
' Parcour les cellules de la colonne
For lRow = 1 To lRowMax - 1
' Référence la cellule
Set rgCell = rgHdrCell.Offset(lRow, 0)
' Texte de la cellule
sText = rgCell.Text
' S'il y a un # venant d'un champ hypertexte Access
lPos = InStr(1, sText, "#")
If lPos > 0 Then
' Texte du lien
sDispl = Left(sText, lPos - 1)
' Adresse du lien
sAddr = Mid(sText, lPos + 1)
' Ajouter lien hypertexte dans la feuille
' à l'emplacement de la cellule référencée par rgCell
xlSht.Hyperlinks.Add rgCell, sAddr, , sAddr, "Lien"
End If
Next
' Sauve le classeur
xlWbk.Save
End If
' Libérer variables objets
Set xlSht = Nothing
xlWbk.Close
Set xlWbk = Nothing
If bQuitXl Then xlApp.Quit
Set xlApp = Nothing
End Sub |
Partager