اريد كود لاستخراج جميع الروابط في صفحة ويب

اني انتظر

وعليكم السلام:

تفضل اخي ها هو الكود

Sub StripLink(Filename As String)
	Dim FFile, FrFile, H, Y, P, E, LineCount As Integer
	Dim TheText, HyperLink As String
	Dim IsInAnotherLine
	ReDim LineData(0) As String
	On Error Resume Next
	' Set the mousepointer to the hourglass pointer.
	Screen.MousePointer = 11
	' Give FFile a free file handle.
	FFile = FreeFile
	' Open the HTML file in read mode.
	Open Filename For Input As #FFile
		' Get FrFile the Free File handle.
		FrFile = FreeFile
		' Open the old filename with the extension "TXT".
		Open Left(Filename, InStr(Filename, ".")) & "TXT" For Output As #FrFile
			' Go through the entire file
			Do While Not EOF(FFile)
				IsInAnotherLine = True

				' Read it line by line.
				Line Input #FFile, TheText
				LineCount = LineCount + 1
				ReDim Preserve LineData(LineCount)
				LineData(LineCount) = TheText
				' Look for all HyperLinks in the File.
				For P = 1 To Len(TheText)
					If Mid(UCase(TheText), P, 7) = "<A HREF" Then
						' Save the position
						H = P
						IsInAnotherLine = False
					ElseIf Mid$(UCase(TheText), P, 4) = "</A>" Then
						Y = P + 4
						If IsInAnotherLine Then
							' If there are links continuing in the next line, then look
							' in the next line, and use them.
							For E = 1 To LineCount
								If E = 1 Then
									HyperLink = Right$(LineData(E), Len(LineData(E)) - H + 1)
								Else
									HyperLink = HyperLink & LineData(E)
								End If
							Next
							' Now add the Closing piece.
							HyperLink = HyperLink & Mid$(TheText, 1, Y)
						Else
							' Just extract the text between H and Y.
							HyperLink = Mid(TheText, H, Y - H)
						End If
						' Write the Links to the text.
						Print #FrFile, HyperLink
						' Reset the LineData array.
						Erase LineData
						LineCount = 0
						H = 0
					End If
					If H = 0 Then
						Erase LineData
						LineCount = 0
					End If
				Next
				' Go to the Next line.
			Loop
			' Close both files.
		Close #FFile
	Close #FrFile
	' Reset the mousepointer to the normal.
	Screen.MousePointer = 0
End Sub

مشكور أخي ما قصرت