'### Constante à adapter ###
Const MY_URL = "http://www.excel-downloads.com/forum/133466-extraire-toutes-les-url-dune-page-web-hyperlien-ou-non.html"
'###########################
Declare Function InternetOpen& Lib "wininet" Alias "InternetOpenA" ( _
ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long)
Declare Function InternetCloseHandle& Lib "wininet" (ByVal hInet As Long) 'As Integer
Declare Function URLDownloadToFile& Lib "urlmon" Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long)
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const FICHIER_TEMPO As String = "C:\___tempo_pmo.txt"
Sub ExtraireUrls()
Dim Inet&
Dim canal&
Dim A$
Dim T()
Dim T2()
Dim COLOR()
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim S As Worksheet
Dim R As Range
Dim CALAGE_CHAR_FIN As Variant
'--- Spécifie les différents caractères de fin
'--- Adaptez l'instruction ci-dessous pour ajouter
'--- d'éventuels autres caractères de fin
'--- Ex : CALAGE_CHAR_FIN = Array(Chr(34), " ", ".", "]",".zip")
CALAGE_CHAR_FIN = Array(Chr(34), " ")
'---------------------------
Inet& = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
Inet& = URLDownloadToFile(0, MY_URL, FICHIER_TEMPO, 0, 0)
Call InternetCloseHandle(Inet&)
canal& = FreeFile
Open FICHIER_TEMPO For Input As #canal&
While Not EOF(canal&)
i& = i& + 1
ReDim Preserve T(1 To i&)
Line Input #canal&, T(i&)
Wend
Close #canal&
For i& = 1 To UBound(T)
A$ = T(i&)
j& = InStr(1, A$, "http://")
If j& > 0 Then
For h& = LBound(CALAGE_CHAR_FIN) To UBound(CALAGE_CHAR_FIN)
k& = InStr(1, Mid(A$, j& + 1), CALAGE_CHAR_FIN(h&))
If k& > 0 Then Exit For
Next h&
cpt& = cpt& + 1
ReDim Preserve T2(1 To cpt&)
ReDim Preserve COLOR(1 To cpt&)
If h& > UBound(CALAGE_CHAR_FIN) Then h& = 29
COLOR(cpt&) = h& + 1
If k& > 0 Then
T2(cpt&) = Mid(A$, j&, k& + Len(CALAGE_CHAR_FIN(h&)))
If Mid(A$, j& - 1, 1) = Chr(34) Then T2(cpt&) = Chr(34) & T2(cpt&)
Else
T2(cpt&) = Mid(A$, j&)
End If
End If
Next i&
If cpt& > 0 Then
Erase T
ReDim T(1 To UBound(T2), 1 To 1)
For i& = 1 To UBound(T2)
T(i&, 1) = T2(i&)
Next i&
Set S = Sheets.Add(after:=Sheets(Sheets.Count))
Set R = S.Range("a1:a" & UBound(T) & "")
R = T
End If
S.Columns(1).Insert
For i& = 1 To R.Rows.Count
Range("a" & i& & "") = COLOR(i&)
Range("b" & i& & "").Font.ColorIndex = COLOR(i&)
Next i&
S.Cells.Columns.AutoFit
If Dir(FICHIER_TEMPO) <> "" Then Kill FICHIER_TEMPO
End Sub