楽天ランキングページのアフィリエイトリンク自動作成（WSH）

キャンペーン実施中!日本ファースト証券資料請求でCOCO壱番館500円飲食券を1枚プレゼント
↓より資料請求いただき、こちらのフォームより(1)資料請求日、(2)送付先の住所・お名前を連絡ください

楽天ランキングページのアフィリエイトリンク自動作成（WSH）

楽天ランキング市場のリンクを自分用のアフィリエイトのリンクに変更してhtmをつくるシェル
■Windows/XP,IE6で動作確認済み
■使いかた
1.拡張子.vbsで適当なファイルを作成する
2.このvbsファイルをエディタで開く
3.下記ソースをコピー、上記で開いた.vbsのファイルに貼り付ける
4.保存・終了する
5.このvbsを実行（ダブルクリック）すると下記(1)→(2)(3)→(2)(3)の繰り返し
(1)楽天のランキングTOP画面
　(2)アフィリエイトリンク作成のURL入力画面にURL入力
(3)作成されたアフィリエイトリンクの画面
5.rakutenRank.htmに自分用のアフィリエイトのリンクに変更したものができているのでそいつを自分のホームページなどにコピー

■ソース

Dim objIE0
Dim s
'対象画面を検索、なければ開く（必要に応じ使用してください）
Set xShell = CreateObject("Shell.Application")
win_s = False
For Each Window In xShell.Windows '対象URLが表示されているか？
 If TypeName(Window.Document) = "HTMLDocument" Then
  if Window.Document.url="http://event.rakuten.co.jp/ranking/" then
   Set objIE0 = Window '対象URLが表示→その画面を使う
   win_s=true
   exit for
  end if
 end if
next
if win_s=false then '対象URLが非表示→新しく画面を開く
 Set objIE0 = CreateObject("InternetExplorer.Application")
 objIE0.Visible = True
 objIE0.Navigate "http://event.rakuten.co.jp/ranking/"
 call ie_wait(objIE0)
end if
set fs = CreateObject("Scripting.FileSystemObject")
Set oTs1 = fs.OpenTextFile("rakutenRank.htm",2,true)
s=objIE0.document.body.innerhtml
key_s="<TABLE cellSpacing=0 cellPadding=3 width=""100%"" border=0>"
s=right(s,len(s)-instr(s,key_s)-len(key_s))
s=right(s,len(s)-instr(s,key_s)+1)
e_pos=instr(s,"<TABLE cellSpacing=0 cellPadding=0 width=""100%"" background=/ranking/img/parts/200508/bg_shopranking.gif border=0>")
e_pos=instr(s,"<TABLE cellSpacing=0 cellPadding=0 width=""100%"" background=/ranking/img/parts/200508/bg_shopranking.gif border=0>")
s=left(s,e_pos-1)
img_dir="http://event.rakuten.co.jp/"
s=replace(s,"src=""/","src=""" & img_dir & "/")
s_save=s
ss=""
key="<A href="""
i=1
dcnt=0
do while i<len(s_save)
 if mid(s,i,len(key))<>key then
  ss=ss & mid(s,i,1)
  i=i+1
 else
  'ss=ss & key
  i=i+len(key)
  turl=mid(s,i,256)
  url=left(turl,instr(turl,"""")-1)
  i=i+instr(turl,"""")
  objIE0.Navigate "http://partner.afl.rakuten.co.jp/af/a_top.cgi"
  call ie_wait(objIE0)
  objIE0.document.all.url.value=url ' text index=6
     'r = MsgBox(url, VbOKCancel, "WS")
     'if r = vbOK Then
     'WScript.Quit
     'end if
  objIE0.document.all.tags("INPUT").item(7).Click 'submit  リンクを作成
  call ie_wait(objIE0)
  urlId=objIE0.document.all.tags("textarea").item(0).value
  ss=ss & left(urlId,instr(urlId,">"))
  i=i+instr(mid(s,i,256),">")
  'dcnt=dcnt+1
  'if dcnt=10 then exit do
 end if
loop
oTs1.writeline ss
oTs1.close
Wscript.quit

Sub ie_wait (objIE)
 kan=false
 do while kan=false
        Do While objIE.busy
        Loop
        Do While objIE.Document.readyState <> "complete"
        Loop
  if instr(objIE.Document.body.outertext,"検索中のページは現在、利用できません。Web サイトに技術的な問題が発")=0 then
   kan=true
  else
   objIE.Refresh
  end if
 loop
End Sub
Function strmid(org,mae,usiro)
 pos = InStr(org, mae)
 If pos > 0 Then
  strmid = Right(org, Len(org) - pos - Len(mae) + 1)
  'org = strmid
  pos = InStr(strmid, usiro)
  If usiro = "" Then
'   strmid = ""
  Else
   If pos > 0 Then
    strmid = Left(strmid, pos - 1)
   End If
  End If
 Else
  strmid = ""
 End If
End Function

■制限事項（作者が分かっている範囲）
・特にないつもりですが、成果の確認なし
■免責うんぬん
・本VBSによる使用者の損害どうのこうの補償は作成者は一切関知しません
　使用者の責においてご利用ください
質問・要望はこちらからその他WSH,EXCEL VBAの活用例紹介しています
こちらのオークションでプログラミングの書籍を出品してます