ファイル名	KawabataCom_Url.wsc
ProgID	KawabataCom.Url
実装形態	WSC (Windows Scripting Componet)
開発言語	VBScript
プロパティ	Timeout
メソッド	GetType ( strUrl ) GetSummary ( strUrl ) GetTitle (strUrl)
利用コンポーネント	basp21
対応する検索サイト	goo, yahoo, msn, msnサーチ, lycos,   excite, フレッシュアイ, infoseek  ocnnavi, netplaza

kawabataCom_Url.wsc (10KB)

適当なフォルダにダウンロードします。
フォルダは、どこでもかまいません。
ASP から利用する場合は、ASP からアクセスできるアクセス権が必要です。

なお、コンポーネントを利用するには、Windows Script 5 以上と、Babaq さんの Basp21 が必要です。

• Windows Script 5
• basp21

WSC コンポーネントを登録するには、つぎのいずれかの方法を使います。

• エクスプローラで、wsc ファイルを選択します。
  右ボタンメニューから、「登録」を実行します。
  
• コマンドプロンプトを開きます。
  regsvr32 kawabataCom_Url.wsc
  を実行します。
  

なお、コンポーネントを登録せずに利用することもできます。
レンタルサーバでコンポーネントの登録が許可されていない場合にも利用できます
レンタルサーバのWindows Script のバージョン、basp21のバージョンの確認をお願いしてください。

コンポーネントを登録している場合は、次のように使います。
Set objUrl = CreateObject("KawabataCom.Url")
コンポーネントを登録していない場合は、次のように使います。
Set objUrl = GetObject("script:C:\Com\KawabatCom_Url.wsc") ファイルのパスは、実際のものに置き換えて使います

メソッドの呼び出しは、次のようになります。

strSummary = objUrl.GetSummary("http://www.lycos.co.jp/cgi-bin/pursuit?cat=jp&query=%89%CD%92%5B") Response.Write strSummary

この場合の戻り値は、「lycos 検索 : 河端」になります。

名前	データ型	初期値	取得	設定	概要
Timeout	long	5000	○	○	ソケットのTimeoutを指定する(単位:ミリ秒)

GetType	URL のタイプを得る
GetSummary	URL の要約を得る
GetTitle	ページの TITLE を得る

GetType

URL のタイプを得る

GetType(strUrl)

strUrl

Url 文字列

戻り値: タイプ文字列 (対象外の場合は、"" )

例: strType = objUrl.GetType("http://www.lycos.co.jp/cgi-bin/pursuit?cat=jp&query=%89%CD%92%5B")
この場合は、strType = 「lycos 検索」となります。

GetSummary

URL の要約を得る

GetSummary(strUrl)

strUrl

Url 文字列

戻り値: 要約文字列 (対象外の場合は、"" )

例: strSummary = objUrl.GetSummary("http://www.lycos.co.jp/cgi-bin/pursuit?cat=jp&query=%89%CD%92%5B")
この場合は、strSummary = 「lycos 検索 : 河端」となります。

GetTitle

ページの TITLE を得る

GetTitle(strUrl)

strUrl

Url 文字列

戻り値: TITLE文字列 (取得できない場合は、"" )

例: strTitle = objUrl.GetTitle("http://www.yahoo.com/")
この場合は、strTitle = 「Yahoo!」となります。

<?xml version="1.0" encoding="Shift_JIS" ?> <component id="kawabataCom.Url"> <?componet error="true" debug="true" ?> <registration progid="kawabataCom.Url" /> <public> 　　<property name="Timeout" put get/> 　　<method name="GetType"> 　　　　<parameter name="strUrl" /> 　　</method> 　　<method name="GetSummary"> 　　　　<parameter name="strUrl" /> 　　</method> 　　<method name="GetTitle"> 　　　　<parameter name="strUrl" /> 　　</method> </public> <script language="VBScript"> <![CDATA[ '--- プロパティ定義 Dim lngTimeout lngTimeout = 5000 '--- Timeoutプロパティを設定 Sub put_Timeout(strValue) 　　On Error Resume Next 　　lngValue = CLng(strValue) 　　If Err <> 0 Then 　　　　Exit Sub 　　End If 　　On Error Goto 0 　　If lngValue <= 0 Then 　　　　Exit Sub 　　End If 　　lngTimeout = lngValue End Sub '--- Timeoutプロパティを取得 Function get_Timeout() 　　get_Timeout = lngTimeout End Function '--- URL のタイプを得る Function GetType(strUrl) 　　Dim lngP, strHost, strType 　　strType = "" 　　lngP = InStr(strUrl, "?") 　　If lngP < 1 Then 　　　　strHost = strUrl 　　Else 　　　　strHost = Left(strUrl, lngP - 1) 　　End If 　　If InStr(1, strHost, "://", vbTextCompare) < 1 Then 　　　　strType = "" 　　ElseIf InStr(1, strHost, "http://www.kawabata.com", vbTextCompare) = 1 Then 　　　　strType = "kawabata.com" 　　ElseIf InStr(1, strHost, "http://www.kawabata.ksi.ne.jp", vbTextCompare) = 1 Then 　　　　strType = "kawabata.com" 　　ElseIf InStr(1, strHost, "http://www.users.gr.jp/ml/archive/", vbTextCompare) > 0 Then 　　　　strType = "users.gr.jp ML" 　　ElseIf InStr(1, strHost, ".goo.ne.jp/", vbTextCompare) > 0 Then 　　　　strType = "goo 検索" 　　ElseIf InStr(1, strHost, "http://search.yahoo.co.jp/", vbTextCompare) > 0 Then 　　　　strType = "yahoo 検索" 　　ElseIf InStr(1, strHost, ".jp.msn.com/", vbTextCompare) > 0 Then 　　　　strType = "msn 検索" 　　ElseIf InStr(1, strHost, "http://search.msn.co.jp/", vbTextCompare) > 0 Then 　　　　strType = "msnサーチ 検索" 　　ElseIf InStr(1, strHost, "http://www.lycos.co.jp/cgi-bin/pursuit", vbTextCompare) > 0 Then 　　　　strType = "lycos 検索" 　　ElseIf InStr(1, strHost, "http://www.excite.co.jp/search.gw", vbTextCompare) > 0 Then 　　　　strType = "excite 検索" 　　ElseIf InStr(1, strHost, "http://search.fresheye.com/", vbTextCompare) > 0 Then 　　　　strType = "フレッシュアイ 検索" 　　ElseIf InStr(1, strHost, "http://www.infoseek.co.jp/Titles", vbTextCompare) > 0 Then 　　　　strType = "infoseek 検索" 　　ElseIf InStr(1, strHost, "http://navi.ocn.ne.jp/cgi-bin/ntt-dir-tret", vbTextCompare) > 0 Then 　　　　strType = "ocnnavi 検索" 　　ElseIf InStr(1, strHost, "netplaza.biglobe.ne.jp/cgi-bin/search", vbTextCompare) > 0 Then 　　　　strType = "netplaza 検索" 　　End If 　　GetType = strType End Function '--- URL の要約を得る Function GetSummary(strUrl) 　　Dim strType 　　Dim strResult 　　GetSummary = "" 　　strResult = "" 　　If strUrl = "" Then 　　　　Exit Function 　　End If 　　strType = GetType(strUrl) 　　Select Case strType 　　Case "kawabata.com" 　　　　strResult = "" 　　Case "users.gr.jp ML" 　　　　strResult = strType & " : " & GetTitle(strUrl) 　　Case "goo 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("MT", "AW0", "AW1", "AW2")) 　　Case "yahoo 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("p")) 　　Case "msn 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("qt", "oq")) 　　Case "msnサーチ 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("q", "MT")) 　　Case "lycos 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("query")) 　　Case "excite 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("s", "search")) 　　Case "フレッシュアイ 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("kw")) 　　Case "infoseek 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("qt","oq")) 　　Case "ocnnavi 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("keyword")) 　　Case "netplaza 検索" 　　　　strResult = strType & " : " & GetSummaryKey(strUrl, "Any", Array("key")) 　　Case Else 　　　　strResult = GetTitle(strUrl) 　　End Select 　　GetSummary = strResult End Function '--- URL からキーワードの一覧を得る Function GetSummaryKey(strUrl, strCode, aryKey) 　　GetSummaryKey = JoinQueryStringValue(GetQueryStringMask(strUrl, strCode, aryKey), ",") End Function '--- クエリー変数の配列を文字列に連結する Function JoinQueryStringValue(aryQ, strDelim) 　　Dim strResult, strValue 　　Dim lngQ 　　strResult = "" 　　For lngQ = LBound(aryQ) To UBound(aryQ) 　　　　strValue = aryQ(lngQ)(1) 　　　　If strValue <> "" Then 　　　　　　If strResult <> "" Then 　　　　　　　　strResult = strResult & strDelim 　　　　　　End If 　　　　　　strResult = strResult & aryQ(lngQ)(1) 　　　　End If 　　Next 　　JoinQueryStringValue = strResult End Function '--- クエリー変数から指定のキーワードのみ配列として得る Function GetQueryStringMask(strUrl, strCode, aryKey) 　　Dim aryR(), aryU, lngR, lngU, lngK 　　Redim Preserve aryR(-1) 　　GetQueryStringMask = aryR 　　aryU = GetQueryString(strUrl, strCode) 　　lngR = -1 　　For lngU = LBound(aryU) To UBound(aryU) 　　　　For lngK = LBound(aryKey) To UBound(aryKey) 　　　　　　If StrComp(aryU(lngU)(0), aryKey(lngK), vbTextCompare) = 0 Then 　　　　　　　　lngR = lngR + 1 　　　　　　　　Redim Preserve aryR(lngR) 　　　　　　　　aryR(lngR) = aryU(lngU) 　　　　　　　　Exit For 　　　　　　End If 　　　　Next 　　Next 　　GetQueryStringMask = aryR End Function '--- クエリー変数を配列として得る Function GetQueryString(strUrl, strCode) 　　Dim aryA, aryB, aryC, strKey, strValue, lngN 　　Dim aryResult() 　　Redim aryResult(-1) 　　GetQueryString = aryResult 　　aryA = Split(strUrl, "?") 　　If Not IsArray(aryA) Then 　　　　Exit Function 　　End If 　　If UBound(aryA) < 1 Then 　　　　Exit Function 　　End If 　　aryB = Split(aryA(1), "&") 　　If Not IsArray(aryB) Then 　　　　Exit Function 　　End If 　　Redim aryResult(UBound(aryB)) 　　For lngN = LBound(aryB) To UBound(aryB) 　　　　aryC = Split(aryB(lngN), "=") 　　　　strKey = URLDecode(aryC(0), strCode) 　　　　strValue = URLDecode(aryC(1), strCode) 　　　　aryResult(lngN) = Array(strKey, strValue) 　　Next 　　GetQueryString = aryResult End Function '--- クエリー変数を特定の文字コードからUnicode文字列に変換する Function URLDecode(strUrlAny, strCode) 　　Dim strUrl 　　Select Case strCode 　　Case "EUC" 　　　　strUrl = URLDecodeAny(strUrlAny, 2) 　　Case "ShiftJIS" 　　　　strUrl = URLDecodeAny(strUrlAny, 1) 　　Case "Any" 　　　　strUrl = URLDecodeAny(strUrlAny, 0) 　　Case Else 　　　　strUrl = strUrlAny 　　End Select 　　URLDecode = strUrl End Function '--- クエリー変数をUnicode文字列に変換する Function URLDecodeAny(strUrlAny, lngCode) 　　Dim strHexAny, byteAny, strUni, strHex 　　Dim lngN, lngSize 　　Dim chrN 　　Dim objBasp 　　URLDecodeAny = "" 　　Set objBasp = CreateObject("Basp21") 　　strHexAny = "" 　　lngN = 1 　　lngSize = Len(strUrlAny) 　　Do While lngN <= lngSize 　　　　chrN = Mid(strUrlAny, lngN, 1) 　　　　If chrN = "+" Then 　　　　　　strHex = Hex(AscB(" ")) 　　　　　　lngN = lngN + 1 　　　　ElseIf chrN <> "%" Then 　　　　　　strHex = Hex(AscB(chrN)) 　　　　　　lngN = lngN + 1 　　　　Else 　　　　　　strHex = Mid(strUrlAny, lngN + 1, 2) 　　　　　　lngN = lngN + 3 　　　　End If 　　　　strHexAny = strHexAny & strHex 　　Loop 　　If strHexAny <> "" Then 　　　　byteAny = objBasp.ByteArray(strHexAny, 1) 　　　　strUni = objBasp.KConv(byteAny, 4, lngCode) 　　　　URLDecodeAny = strUni 　　End If End Function '--- URL からプロトコルを返す Function GetUrlProtocol(strUrl) 　　Dim lngP 　　GetUrlProtocol = "" 　　lngP = InStr(1, strUrl, ":", vbTextCompare) 　　If lngP > 0 Then 　　　　GetUrlProtocol = LCase(Left(strUrl, lngP - 1)) 　　End If End Function '--- URL からホスト名を返す Function GetUrlHost(strUrl) 　　Dim lngP, strHost 　　GetUrlHost = "" 　　strHost = "" 　　lngP = InStr(1, strUrl, "//", vbTextCompare) 　　If lngP > 0 Then 　　　　strHost = Mid(strUrl, lngP + 2) 　　　　lngP = InStr(1, strHost, ":", vbTextCompare) 　　　　If lngP > 0 Then 　　　　　　strHost = Left(strHost, lngP - 1) 　　　　End If 　　　　lngP = InStr(1, strHost, "/", vbTextCompare) 　　　　If lngP > 0 Then 　　　　　　strHost = Left(strHost, lngP - 1) 　　　　End If 　　End If 　　GetUrlHost = strHost End Function '--- URL からポート番号を返す Function GetUrlPort(strUrl) 　　Dim lngP, lngPort, strPort 　　GetUrlPort = "" 　　lngPort = 80 　　lngP = InStr(1, strUrl, "//", vbTextCompare) 　　If lngP > 0 Then 　　　　strHost = Mid(strUrl, lngP + 2) 　　　　lngP = InStr(1, strUrl, "/", vbTextCompare) 　　　　If lngP > 0 Then 　　　　　　strHost = Left(strHost, lngP - 1) 　　　　End If 　　　　lngP = InStr(1, strUrl, ":", vbTextCompare) 　　　　If lngP > 0 Then 　　　　　　strPort = Mid(strHost, lngP + 1) 　　　　　　If IsNumeric(strPort) Then 　　　　　　　　On Error Resume Next 　　　　　　　　lngPort = CLng(strPort) 　　　　　　　　If Err <> 0 Then 　　　　　　　　　　lngPort = 80 　　　　　　　　End If 　　　　　　　　On Error Goto 0 　　　　　　End If 　　　　End If 　　End If 　　GetUrlPort = lngPort End Function '--- URL からパスを返す Function GetUrlPath(strUrl) 　　Dim lngP, strPath 　　GetUrlPath = "" 　　strPath = "/" 　　lngP = InStr(1, strUrl, "//", vbTextCompare) 　　If lngP > 0 Then 　　　　strPath = Mid(strUrl, lngP + 2) 　　　　lngP = InStr(1, strPath, "/", vbTextCompare) 　　　　If lngP < 1 Then 　　　　　　strPath = "/" 　　　　Else 　　　　　　strPath = Mid(strPath, lngP) 　　　　　　lngP = InStr(1, strPath, "?", vbTextCompare) 　　　　　　If lngP > 0 Then 　　　　　　　　strPath = Left(strPath, lngP - 1) 　　　　　　End If 　　　　End If 　　End If 　　GetUrlPath = strPath End Function '--- URL からクエリー変数を返す Function GetUrlQuery(strUrl) 　　Dim lngP, strPath, strQuery 　　GetUrlQuery = "" 　　strQuery = "" 　　lngP = InStr(1, strUrl, "//", vbTextCompare) 　　If lngP > 0 Then 　　　　strPath = Mid(strUrl, lngP + 2) 　　　　lngP = InStr(1, strPath, "?", vbTextCompare) 　　　　If lngP > 0 Then 　　　　　　strQuery = Mid(strPath, lngP + 1) 　　　　End If 　　End If 　　GetUrlQuery = strQuery End Function '--- ページの TITLE を返す Function GetTitle(strUrl) 　　Dim strProtocol, strHost, lngPort, strPath, strQuery 　　Dim objBasp, objSocket 　　Dim lngResult, strLine, strHeader, strTitle, strCommand 　　Dim lngP 　　GetTitle = "" 　　strProtocol = GetUrlProtocol(strUrl) 　　If StrComp(strProtocol, "http", vbTextCompare) <> 0 Then 　　　　Exit Function 　　End If 　　strHost = GetUrlHost(strUrl) 　　lngPort = GetUrlPort(strUrl) 　　strPath = GetUrlPath(strUrl) 　　strQuery = GetUrlQuery(strUrl) 　　'--- ソケットオブジェクト 　　Set objSocket = CreateObject("BASP21.Socket") 　　'--- サーバーに接続 　　lngResult = objSocket.Connect(strHost, lngPort, lngTimeout) 　　If lngResult <> 0 Then 　　　　Exit Function 　　End If 　　'--- リクエストを送信 　　If strQuery <> "" Then 　　　　strPath = strPath & "?" & strQuery 　　End If 　　strCommand = _ 　　　　"GET " & strPath & " HTTP/1.1" & vbCrLf _ 　　　　& "Host: " & strHost & vbCrLf _ 　　　　& "Accept: */*" & vbCrLf _ 　　　　& "Accept-Language: ja" & vbCrLf _ 　　　　& "Connection: Keep-Alive" & vbCrLf _ 　　　　& vbCrLf 　　lngResult = objSocket.Write(strCommand) 　　If lngResult <> 0 Then 　　　　Exit Function 　　End If 　　'--- レスポンスヘッダー部分を処理する 　　lngResult = objSocket.ReadLine(strLine) 　　If lngResult <> 0 Then 　　　　Exit Function 　　End If 　　If InStr(1, strLine, " 200 OK", vbTextCompare) < 0 Then 　　　　Exit Function 　　End If 　　Do 　　　　lngResult = objSocket.ReadLine(strLine) 　　　　If lngResult <> 0 Then 　　　　　　Exit Function 　　　　End If 　　　　If Len(strLine) = 0 Then 　　　　　　'--- ヘッダー部分終了 　　　　　　Exit Do 　　　　End If 　　Loop 　　'--- HTML ヘッダーを得る 　　strHeader = "" 　　Do 　　　　lngResult = objSocket.ReadLine(strLine) 　　　　If lngResult = -3 Then 　　　　　　Exit Do 　　　　End If 　　　　If lngResult <> 0 Then 　　　　　　Exit Function 　　　　End If 　　　　'--- ヘッダー部分を改行を無視して、すべて連結する 　　　　strHeader = strHeader & strLine 　　　　'--- ヘッダー終了 　　　　If InStr(1, strLine, "</head>", vbTextCompare) > 0 Then 　　　　　　Exit Do 　　　　End If 　　Loop 　　'--- ソケットを解放 　　objSocket.Close 　　Set objSocket = Nothing 　　'--- 文字コード変換 　　Dim baryHeader 　　Set objBasp = CreateObject("Basp21") 　　baryHeader = objBasp.ByteArray(strHeader) 　　strHeader = objBasp.KConv(baryHeader, 4) 　　'--- ヘッダー部分から TITLE の切り出し 　　strTitle = "" 　　lngP = InStr(1, strHeader, "<TITLE>", vbTextCompare) 　　If lngP > 0 Then 　　　　lngP = InStr(lngP, strHeader, ">", vbTextCompare) 　　　　If lngP > 0 Then 　　　　　　strTitle = Mid(strHeader, lngP + 1) 　　　　　　lngP = InStr(1, strTitle, "<") 　　　　　　If lngP > 0 Then 　　　　　　　　strTitle = Left(strTitle, lngP - 1) 　　　　　　End If 　　　　End If 　　End If 　　GetTitle = strTitle End Function ]]> </script> </component>

クエリー変数部分から検索エンジンに合わせて、キーワード部分を抜き出してきています。
文字コードは、basp21 の文字コード変換に任せています。

検索エンジンへの対応を増やしていきたいですね
YahooやFind'X などのディレクトリタイプのポータルからのアクセスの場合は、どの分類から
参照されているのかをしらべたいと思います。
また、通常のサイトについても、Desciription, H1 などから、適当な内容をとってきて
返すようにしたいと思います。

2000.6.13

ページのタイトル(TITLE) を所得する機能を追加 (Timeout, GetTitle) wscのエンコードをUnicodeからShift_JIS に変更 wscのダウンロードがうまくできない問題に対策 ocnnavi, netplaza 対応追加 GetSummary で、TITLE も取得するように変更 GetSummary で、users.gr.jp/ml に対応