HTMLソースからURLだけを抜き出す方法を教えてください！

質問

どなたかお知恵をお貸しください。
HTMLのソースファイルからURLを取得するツールを
作ろうと思うのですが、そのURLだけを抜き出すと
いうところがよく分かりません。

ソーステキストを
open "source.txt" for input as #1
do until eof(1)
line input #1,aa
で一行ずつ読み込んでいき、
その中から
InStr関数で「http://」の文字列を検索すると
いうことぐらいは想像がつくのですが、URLは
文字数も決められているわけではないので、検索で
見つかった位置から最後までを抜き出すという方法が
どうしても分かりません。

あるいは、タグの <A href= という文字列を検索して
見つかった位置から次に > という文字列が見つかった
場所までの間を抜き出すという方法になるかと思いますが、
最初に検索で見つかった位置から次に見つかった位置まで
をどのように検索すればいいのかが分かりません。

何かいい手がございましたら、ぜひ教えてください。
よろしくお願いします！

回答No.7

hershe · ベストアンサー

こんにちわ。#4のhersheです。

補足の回答をいたします。

改行なしの場合もInStr関数の使い方を少し工夫するだけでタグの抽出を行うことができます。

>途中で改行されても続けて検索する方法、
この方法は少し複雑なコードになってしまいますので

>改行がなく全文で一行の場合でも続けてURLを取得していきリストボックスに
>追加していくような方法はないのでしょうか？
こちらの方法で記述しますね。

fujiyama2002さんのコードを少しお借りします。

'--------+---------+---------+---------+---------+---------+
　　Open na For Input As #fileno

　　Do Until EOF(fileno)
　　　　Line Input #fileno, aa

　　　　GetATag = ""

　　　　lngPosSt = InStr(StrConv(aa, vbLowerCase), "<a href=")

　　　　'"<a href="が見つかったらループ
　　　　Do While lngPosSt > 0
　　　　　　GetATag = ""

'　　　　　　If lngPosSt > 0 Then
　　　　　　　　lngPosEnd = InStr(Mid(aa, lngPosSt), ">")

　　　　　　　　If lngPosEnd > 0 Then
　　　　　　　　　　strATag = Mid(aa, lngPosSt, lngPosEnd)
　　　　　　　　　　GetATag = strATag
　　　　　　　　End If
'　　　　　　End If
　　　　　　if GetATag <> ""
　　　　　　　　List1.AddItem GetATag
　　　　　　End If

　　　　　　'検索開始位置を次の位置へ
　　　　　　lngPosSt = lngPosSt + lngPosEnd

　　　　　　'次の"<a href="を検索
　　　　　　lngPosSt = InStr(lngPosSt, StrConv(aa, vbLowerCase), "<a href=")
　　　　Loop
　　Loop

　　Close #fileno
'--------+---------+---------+---------+---------+---------+

このように検索開始位置をずらしつつ検索を繰り返すことによって、全文で１行の場合でも抽出できるようになります。

また、"<a href="の部分を"<a "に変更することで、"TARGET="などが"<a"と"href"の間に入っている場合のものも抽出できるようになります。

あとはＵＲＬを抜き出すだけですね。
もうひと踏ん張りです。がんばりましょう。(^-^)

お礼

こんにちは。
詳細な回答をまたまたありがとうございます！

コードをそのままコピーさせていただいて、部分的に変更しながら
いろんなパターンを試してみました。
"<a"を"<a href"とか"http"に変えて試してみました。
結局下のコードできれいに抽出できました。

Open na For Input As #fileno
Do Until EOF(fileno)
Line Input #fileno, a
getatag = ""
lngposst = InStr(StrConv(aa, vbLowerCase), "<a")
Do While lngposst > 0
getatag = ""
'　　　　　　If lngPosSt > 0 Then
lngposend = InStr(Mid(aa, lngposst), ">")
If lngposend > 0 Then
stratag = Mid(aa, lngposst, lngposend)
getatag = stratag
End If
'　　　　　　End If
If getatag <> "" Then
yyyyy = StrConv(getatag, vbLowerCase)
ooo = Replace(yyyyy, "<a href=", "")
www = Replace(ooo, ">", "")
saigo = Replace(www, """", "")
List1.AddItem saigo
End If
lngposst = lngposst + lngposend
lngposst = InStr(lngposst, StrConv(aa, vbLowerCase), "<a")
Loop
Loop
Close #fileno

これでどうやらきれいにリストボックスに追加されました。
途中に改行が入っているソースでも試しましたが、URLの途中に
改行が入っているものは案外とないようで、ちゃんと出力されて
いましたので、ここのところはとりあえず無視してしまうことにしました。
あと、間に「target」が入っているものもたまたま見つからなかったので
とりあえずReplaceには入れていませんが、これは教えていただいた
方法で位置を割り出してtargetからhttpの前までを削除してしまうことで
解決するかと思います。

次はgifなどの画像も取り込んでしまおうと思います。
これは、上の例で言うと、aaの中に.gifの文字列があったらその位置までを
抽出するという方法でどうにかなりそうだと、自分で勝手に思っています。
ほぼ100%が教えていただいた方法でどうにかなりそうな気がします。

ほんとにありがとうございました！

回答No.6

tinu 2000（@tinu2000）

#2のtinu2000です。
気が付かれたように、全文で一行として最初のLine Input #1, naiyou で読み込んでいますね。
仕事場のＰＣにはＶＢが入って無いので、ＶＢＡで試してみました。
ＶＢＡでは、ちゃんと一行づつ読み込んで問題なかったです。
ＶＢではダメなのかな？
この問題は別の質問で聞いて見て下さい。
明確な回答が得られると思います。

では、本題です。
一行づつでも、全文でも、どちらでも良いように考えました。

ただ、
#3の方が書かれているように、"TARGET="文があると、抜き出しが出来ません。
ページ移動の<A href="gazou/hana.htm">などは、gazou/hana.htm と抜き出します。

あとは、よしなに！！

*----------------- ここから -------------
Option Explicit
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim naiyou As String
Dim bb As String

Private Sub Form_Load()

Open "source.txt" For Input As #1

Do While Not EOF(1)
Line Input #1, naiyou
k = 0
Do
bb = ""
i = InStr(k + 1, naiyou, "<a href=", 1)
If i = 0 Then Exit Do
j = InStr(i + 1, naiyou, ">", 1)
If j = 0 Then Exit Do
bb = Mid(naiyou, i + 9, j - i - 10)
If Len(bb) <> 0 Then List1.AddItem bb
k = j
Loop
Loop
Close #1
End Sub
*------------------ ここまで -------------

お礼

ご回答ありがとうございます。

hersheさんに教えていただいた分とtinu2000さんに教えていただいた分を
交互に入れ替えながら、またところどころ修正しながら試してみました。
確かにおっしゃるように<A href="gazou/hana.htm">のような部分も
抜き出していました。

改行が入っていても全文で一行でもOKむというのがとても魅力的です。
hersheさんの分とtinu2000さんの分の両方のコードをうまくミックスして
しまえたらいいのですが、なかなか私のレベルではまだまだそこまで
は難しいです。

何回も修正しながらコードを試していくというのが結構勉強になり
しかもなかなかおもしろいので、また教えていただいた方法を元に
試行錯誤したいと思います。

ほんとにありがとうございました！！！！！！！

と言いつつレベルの低い私ですので、また分からないことが
ありましたら質問させていただきたいと思います。
その時はよろしくお願いします！

回答No.5

noname#21649

ＶＢでなくＭＢのルーチンです。参考にして下さい。
これは，多少間違えた指定でも引き抜く事が出来ます。
ＪＡＶＡ対応のルーチンは分量が多くてかけません。JAVA参照を一旦＜A>タグに変更してから使用するようにしています。

SUB SepURL (A$, Add$, ADD2$)
'A$ 入力文字列
'Add$ アドレス単体
'ADD2$ 通信手順＋アドレス
B$ = CHR$(&H22): B$ = B$ + B$: IA% = INSTR(A$, B$): IF IA% > 0 THEN A$ = LEFT$(A$, IA%) + MID$(A$, IA% + 2)
'""http: や html""> のように ""の連続があったため，ひとつを消す
IA% = INSTR(A$, "http:") + INSTR(A$, "https:") + INSTR(A$, "ftp:")
IF IA% = 0 THEN
Add$ = "": 'アドレス単体
ADD2$ = "": '通信手順＋アドレス
ELSE
ID% = INSTR(IA%, A$, ":")
IB% = INSTR(ID%, A$, CHR$(&H22))
IF IB% > 0 THEN
IC% = IB% - ID%
Add$ = MID$(A$, ID% + 3, IC% - 3): 'アドレス単体
ADD2$ = MID$(A$, IA%, IB% - IA%): '通信手順＋アドレス
ELSE
IB% = INSTR(ID%, A$, " ")
IC% = INSTR(ID%, A$, ">")
IF IB% = 0 THEN
IB% = IC%
IC% = IB% - ID%
Add$ = MID$(A$, ID% + 3, IC% - 3): 'アドレス単体
ADD2$ = MID$(A$, IA%, IB% - IA%): '通信手順＋アドレス
A$ = LEFT$(A$, IA% - 1) + CHR$(&H22) + ADD2$ + CHR$(&H22) + MID$(A$, IB%)
ELSEIF IB% > IC% THEN
IB% = IC%
IC% = IB% - ID%
Add$ = MID$(A$, ID% + 3, IC% - 3): 'アドレス単体
ADD2$ = MID$(A$, IA%, IB% - IA%): '通信手順＋アドレス
A$ = LEFT$(A$, IA% - 1) + CHR$(&H22) + ADD2$ + CHR$(&H22) + MID$(A$, IB%)
ELSE
STOP
Add$ = "": 'アドレス単体
ADD2$ = "": '通信手順＋アドレス
END IF
END IF
END IF
END SUB

お礼

ご回答いただき、ありがとうございました。

回答No.4

hershe

#3のものです。

ごめんなさい。質問の答えになっていなかったですね。

>最初に検索で見つかった位置から次に見つかった位置まで
>をどのように検索すればいいのかが分かりません。

これは、InStr関数を使用すればできます。

InStr([検索開始位置],文字列,検索文字)

※[検索開始位置]は省略可能です。省略すると1になります。

例)「<A HREF="xxx.html">」から「"」～「"」までを検索します。

'--------+---------+---------+---------+---------+---------+
Dim lngPosSt　As Long
Dim lngPosEnd As Long
Const strText As String = "<A HREF=""xxx.html"">"

'文字列の最初から「"」を検索
lngPosSt = InStr(strText , Chr(34))

'「"」が見つかった位置の一つ後ろから次の「"」を検索
lngPosEnd = InStr(lngPosSt + 1, strText , Chr(34))

'「"」～「"」までをメッセージに出力
MsgBox Mid(strText , lngPosSt, lngPosEnd - lngPosSt + 1)

'--------+---------+---------+---------+---------+---------+

このようにすると検索できます。

お礼

ご回答いただきありがとうございます。
しかもこんなに詳細にご説明いただき
とても助かります。
じっくり読んで試してみます。

補足

こんにちは。

教えていただいた方法を活用してコードを書こうと思ったのですが、
これがめちゃくちゃ難しいです。
とりあえずこんな感じで使わせていただきました。

Open na For Input As #fileno
Do Until EOF(fileno)
Line Input #fileno, aa

GetATag = ""
lngPosSt = InStr(StrConv(aa, vbLowerCase), "<a href=")

If lngPosSt > 0 Then
lngPosEnd = InStr(Mid(aa, lngPosSt), ">")

If lngPosEnd > 0 Then
strATag = Mid(aa, lngPosSt, lngPosEnd)
GetATag = strATag
End If
End If
List1.AddItem GetATag
Loop
Close #fileno

これでいくと、とりあえず最初のURL(a hrefとかを消す前の状態まで)は
取得できたのですが、何故か一つ目しか取得しないので、悩んだのですが
HTMLのソースに改行がなく、全文で一つの行になっていたため、最初の
一つしか取得できないのだと分かりました。

それで、今度はソフト改行コードを入れたらどうだろうと考えまして、
次のようにしてみました。

上のコードで読み込む「na」を作成するのに、

Open na For Input As #fileno
Do Until EOF(fileno)
Line Input #fileno, www
zzz = zzz & www & vbCrLf
Loop
Close #fileno
Text2.Text = zzz
With Text2
lngResult = _
SendMessage( _
.hWnd, _
EM_FMTLINES, _
CLng(Abs(True)), _
ByVal CLng(0))
Text3.Text = Replace(.Text, _
vbCr & vbNewLine, _
vbNewLine)
End With

Open na For Output As #fileno
Print #fileno, Text3.Text
Close #fileno

こんな風に一度改行コードを付与してから、また「na」という
テキストに書き込んでみました。
で、このファイルを Line Input で読み込ませてみたのですが、
ご想像の通り、タグの途中でバシバシ改行されているため
ほぼURLは取得できませんでした。

ここまででほとんどお手上げ状態です！！！

途中で改行されても続けて検索する方法、あるいは
改行がなく全文で一行の場合でも続けてURLを取得していきリストボックスに
追加していくような方法はないのでしょうか？

すみません、まだまだレベルが低いもので。
よろしくお願いいたします

回答No.3

hershe

こんにちわ。hersheというものです。

タグの検索ですが"<a href="で検索しただけでは、
"<a"と"href"の間に"TARGET="など他の設定が入った場合、検索できなくなってしまいます。
ですので、まずは"<a"のタグを">"まで検索した後に"href"以降のURLを抜き取る必要があります。

"A"タグを抽出する関数を作ってみましたので記載します。

'--------+---------+---------+---------+---------+---------+
' "A"タグ抽出関数
'--------+---------+---------+---------+---------+---------+
Private Function GetATag(pstrLineBuf As String) As String
　　Dim lngPosSt As Long
　　Dim lngPosEnd As Long
　　Dim strATag As String

　　GetATag = ""

　　'文字が大文字か小文字か分からないためStrConv関数で小文字に変換した後、比較します。
　　lngPosSt = InStr(StrConv(pstrLineBuf, vbLowerCase), "<a")

　　'"<A"が見つかった場合、">"を検索します。
　　If lngPosSt > 0 Then
　　　　lngPosEnd = InStr(Mid(pstrLineBuf, lngPosSt), ">")

　　　　'">"が見つかった場合、"<A"～">"を抜き出し戻り値として返します。
　　　　If lngPosEnd > 0 Then
　　　　　　strATag = Mid(pstrLineBuf, lngPosSt, lngPosEnd)
　　　　　　GetATag = strATag
　　　　End If
　　End If

End Function
'--------+---------+---------+---------+---------+---------+

この関数は"A"タグが見つかった場合、返値に"<A"～">"が返ってきます。見つからない場合は空白("")です。
>line input #1,aa
の後に

'--------+---------+---------+---------+---------+---------+
　　strRet = GetATag(aa)
　　If strRet <> "" Then
　　　　MsgBox strRet
　　End If
'--------+---------+---------+---------+---------+---------+

と記述して試してみてください。
あとは抽出した"<A"～">"の中から"HREF"を検索し、URLを抜き出すだけです。

また、問題点を挙げておきます。
・HTMLのタグは複数行に渡って記述することができるため、１行の中に終了文字">"が見つからないことがあります。
・HTMLソースの記述が間違っている場合は、正常に動作しません。

以上です。参考になるでしょうか？

お礼

ご回答ありがとうございます！
二回も詳細に書いていただき恐縮です。
VBについてはまだまだ勉強中でして、検索とか置き換え
というところは最も苦手なところなんです。
でもこれだけ詳しく書いていただいたので、調べつつ
ぜひ試させていただきます。
ありがとうございます！！！

回答No.2

tinu 2000（@tinu2000）

bb=""
i = InStr(1, aa, "<a href=")
if i<>0 then
j= InStr(i+1, aa, ">")
if j<>0 then
bb=mid(aa,i+9,j-i-10)
end if
end if
if len(bb)<>0 then bbの中にhttp://からのURLが入っている。
if len(bb)=0 then aaの中にURLは無かった。

お礼

ご回答いただきありがとうございます。
教えていただいたものをほとんどそっくり引用させていただいて
ちょっと書いてみました。

Open na For Input As #fileno
Do Until EOF(fileno)
Line Input #fileno, naiyou

i = InStr(1, naiyou, "<a href=")

j = InStr(i, naiyou, ">")

bb = Mid(naiyou, i + 9, j - i - 10)
List1.AddItem bb
all = all & bb & vbCrLf
Loop
Close #fileno

これでバッチリと思ったのですが、確かにURLは抜き出せる
のですが、なぜか最初のひとつしか抜き出せませんでした。
ただ今これで悩んでます。
なかなか難しいですね。

回答No.1

taka_tetsu

タグを検索したほうがいいでしょうね。
本文中にurlがかかれている可能性がありますから。

">"を探すの方法は、InStrでいいですよ。

i = InStr(1, str, "<a href=")
で"<a href="が見つかったら、

j = InStr(i, str, ">")
で、"<a href="以降の、">"を探せば見つかるはずです。

あとは、Mid()などで切り出すだけです。

お礼

早速のご回答ありがとうございます！

InStrをあれこれ試してみます。