キャンペーン実施中!日本ファースト証券資料請求で
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="
" 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,"
") e_pos=instr(s,"
") 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="
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の活用例紹介しています
こちらのオークションでプログラミングの書籍を出品してます