212278
ホーム \| 日記 \| プロフィール	【フォローする】【ログイン】

EXCEL VBA TIPS

全54件 (54件中 1-50件目)

1 2 >

北沢署警部補･掛本六男駐車違反住民にインネン

5月20日18時ころ東京都世田谷区小田急線梅が丘駅前品川41 き63-20が障害者用スペースに違法駐車私：犯人3名にやめるよう指示犯人：公報活動”ひったくり防止”なのでいいでしょう私：110通報犯人が警察官らしい私：3人のうち1番悪そうなのに身分証明をみせろ1番悪そうな犯人：瞬間警察手帳らしきものを見せる犯人は警部補･掛本六男私：番号を控えないといけないので何度かちゃんと見せろと命令犯人：さっきちゃんと見せた上記の繰り返し、以下口論になる私：コソドロ一人捕まえたこともないお前がなんで警部補なんだ掛本：そんなことお前には関係ないだろう私：祖師谷の一家4人殺害事件のとき何してた掛本：そんなこと知るわけないだろ私：昨年、秋葉原の無差別殺害事件は掛本：馬鹿野郎、芸者遊びにきまってるだろなどなど掛本が暴言連発通報を受けた警官到着：犯人3人は同僚であると説明犯人3人：逃走

2009.05.21

コメント(40)
FXキングmyページ・ログインシェル作ったよVBS,WSHでのIE操作例

先頭2行をユーザid,パスワードの代入文に変更してくださいid=""pw=""Dim objIE0'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://www.fxking.jp/mypage/Login.action" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://www.fxking.jp/mypage/Login.action" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.fxkingId.value=id ' text index=0objIE0.document.all.password.value=pw ' password index=1objIE0.document.all.btn_login.click ' image btn_login submit or tags("INPUT").item(2).Click

2009.05.21

コメント(0)
郵貯オンライン画面変わったexcel入金取り込み訂正

Dim nyuukin(100) As nyuukin_rowDim fno_w As Integer, a(999, 5) As String, a_no As Integer, hinichi As String, kingaku As String Dim objIE As Object 'ＩＥオブジェクト参照用 Sheets("入金").Select 'On Error GoTo keke 'インターネットエクスプローラーのオブジェクトを作る Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = True '見えるようにする(お約束) objIE.navigate "https://direct.jp-bank.japanpost.jp/direct_login.html" Call ie_wait(objIE) id = Worksheets("account").Cells(2, 2) ' text index=2objIE.Document.all.okyakusamaBangou1.Value = Left(id, 4) ' text index=2objIE.Document.all.okyakusamaBangou2.Value = Mid(id, 5, 4) ' text index=3objIE.Document.all.okyakusamaBangou3.Value = Mid(id, 9, 5) ' text index=4objIE.Document.all.loginPassword.Value = "" ' password index=5 objIE.Document.all.loginPassword.Value = Worksheets("account").Cells(3, 2) ' password index=3 objIE.Document.all.U010103.Click ' or tags("INPUT").item(7).Click' objIE.Document.all.tags("INPUT").Item(5).Click Call ie_wait(objIE) objIE.Document.all.tags("INPUT").Item(4).Click '取扱内容照会 Call ie_wait(objIE) objIE.Document.all.shoukaiHaniSentaku(0).Checked = True ' radio 日付指定 objIE.Document.all.U070102.Click ' button U070102 次へ or tags("INPUT").item(23).Click Call ie_wait(objIE) kensuu = 0 Do ii = t_Array(objIE, 0, fno_w, 1, a, a_no) For ii = 1 To a_no If Left(a(ii, 3), 2) = "送金" Then kingaku = a(ii, 1) kingaku = strmid(kingaku, ";", "

2009.05.12

コメント(3)
怠慢警官・村上川崎市多摩警察署駐車違反取り締まらず

2/13金11:30-11:50神奈川県川崎市多摩区登戸２７０５ATMコーナー向ケ丘遊園駅前警官sg504村上が振り込め詐欺防止と称しサボり目の前の駐車違反を取り締まるよう指示したが、その場をはなれることができないとの理由で取締りせず。と言ってるのに道案内だけは熱心にやっていた。あげく”交番へ行け”ほか暴言。2/16月17時ころ多摩警察署に苦情・当直”にしがた”が対応2/18水村上が上司とともに謝罪すると電話連絡2/20金10時村上と同僚・山田浩章が私のところへ。謝罪どころか”そのときは振り込め詐欺防止で離れることができなかった、駐車違反は見えなかったと”言い訳2/20金11時　多摩警察署にしがたに苦情・担当上司と相談し対応するとのこと。その際にしがたは、”もう連絡しなくていいですね”とわけのわからん応対2/24火16時の時点で対応なし

2009.02.26

コメント(16)
怠慢警官・村上川崎市多摩警察署駐車違反取り締まらず

2/13金11:30-11:50神奈川県川崎市多摩区登戸２７０５ATMコーナー向ケ丘遊園駅前警官sg504村上が振り込め詐欺防止と称しサボり目の前の駐車違反を取り締まるよう指示したが、その場をはなれることができないとの理由で取締りせず。と言ってるのに道案内だけは熱心にやっていた。あげく”交番へ行け”ほか暴言。2/16月17時ころ多摩警察署に苦情・当直”にしがた”が対応2/18水村上が上司とともに謝罪すると電話連絡2/20金10時村上と同僚・山田浩章が私のところへ。謝罪どころか”そのときは振り込め詐欺防止で離れることができなかった、駐車違反は見えなかったと”言い訳2/20金11時　多摩警察署にしがたに苦情・担当上司と相談し対応するとのこと。その際にしがたは、”もう連絡しなくていいですね”とわけのわからん応対2/24火16時の時点で対応なし

2009.02.26

コメント(6)
クレジットカードの買い物一覧をEXCELに取り込むVBA famima Tカード

ファミマTカードの会員ページ> ご利用明細照会 > ご請求内容の明細より各月の買い物一覧をexcelに取り込みます前提：ワークシート：accountにTcard番号,パスワードがあること。Tcard番号：1行1列、パスワート：2行1列動作：月ごとにご請求内容の明細をブラウズ　　　　ワークシート名として、"年_月"の規則でワークシートを追加　　　　追加したワークシートに一覧を取り込み　　　　"年_月"ワークシートがある場合その時点で止める以下ソースですSub Fichiran()Dim objIE0 As Object'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then If Window.Document.URL = "https://portal.expay.net/servlet/FTPoLogin" Then Set objIE0 = Window '対象URLが表示→その画面を使う win_s = True Exit For End If End IfNextIf win_s = False Then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://portal.expay.net/servlet/FTPoLogin" Call ie_wait(objIE0)End IfobjIE0.Document.all.loginID.Value = Worksheets("account").Cells(1, 1).Value '"" ' Tカード番号objIE0.Document.all.pswd.Value = Worksheets("account").Cells(2, 1).Value ' 暗証番号objIE0.Document.links(0).Click 'javascript:loginServ('FTPoLogin',%20'login')Call ie_wait(objIE0)Call link_click(objIE0, "text_inc", "明細照会")c = toridasi(objIE0)objIE0.Document.all.menu1.selectedIndex = 1 ' （前月）:objIE0.Document.all.menu1.fireEvent ("onchange")Call ie_wait(objIE0)Call link_click(objIE0, "text_inc", "明細照会")c = toridasi(objIE0)objIE0.Document.all.menu1.selectedIndex = 2 ' （前々月objIE0.Document.all.menu1.fireEvent ("onchange")Call ie_wait(objIE0)Call link_click(objIE0, "text_inc", "明細照会")c = toridasi(objIE0)End SubFunction toridasi(objIE As Object) As IntegerDim s As Stringtoridasi = 0s = objIE.Document.body.innerhtmlnen = strmid(s, "<OPTION selected>", "年")tuki = strmid(s, "年", "月")'tuki = strmid(s, ">", "<")sheet_n = nen & "_" & tukiOn Error GoTo kekeSheets(sheet_n).ActivateGoTo enddkeke:On Error GoTo 0toridasi = toridasi + 1Set NewWS = Worksheets.Add '(After:=Worksheets("Sheet3"))With NewWS .Name = sheet_n' .Columns.ColumnWidth = 20End WithSheets(sheet_n).Activates = strmid(s, "<TD class=text vAlign=top>ご利用明", "")s_pos = 2Do Until InStr(s, "<TD borderColor=#666666 align=middle>") = 0 mono = strmid(s, "<TD borderColor=#666666 align=middle>", "<") yymmdd = strmid(s, "<TD borderColor=#666666 align=middle>", "<") shop = strmid(s, "<TD borderColor=#666666>", "<") gaku = strmid(s, "<TD borderColor=#666666 align=right>", "<") Cells(s_pos, 1).Value = yymmdd Cells(s_pos, 2).Value = shop Cells(s_pos, 3).Value = gaku s_pos = s_pos + 1Loopendd:End FunctionFunction strmid(ByRef org As String, ByVal mae As String, ByVal usiro As String) As String 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 IfEnd FunctionFunction link_click(objIE As Object, typ As String, v As String) As Integerlink_click = -1c = 0 For i = 0 To objIE.Document.links.Length - 1 If typ = "text" Then If objIE.Document.links(i).outertext = v Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "text_inc" Then If InStr(objIE.Document.links(i).outerHtml, v) > 0 Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "href" Then If objIE.Document.links(i).href = v Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "href_inc" Then If InStr(objIE.Document.links(i).href, v) > 0 Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "num" Then c = c + 1 If c = CStr(v) Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If NextEnd FunctionFunction ie_wait(objIE As Object) Do While objIE.Busy = True DoEvents Loop ' Do While objIE.Document.readyState <> "complete" DoEvents LoopEnd Function

2009.02.14

コメント(1)
クリック証券API終了とりあえず取引暗証番号を自動入力するシェルで対応wsh,vbs

API使えなくなるので、こいつが必要になってしまったobjIE0.document.body.innerhtmlのオブジェクトなしのエラーを無視するようにしました先頭1行取引暗証番号の代入文にしてください以下ソースですpinCode="" '取引暗証番号の代入文にしてくださいDim objIE0 'ルートのオブジェクト、操作コードではこの名称を使用しますSet xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if instr(Window.Document.url,"https://kabu.click-sec.com")>0 then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextqq=falsedo on error resume next do if instr(objIE0.document.body.innerhtml,"<INPUT class=password id=pinCode")>0 then if err.description<>"" then' if MsgBox(err.description, VbOKCancel, "WS")=vbCancel Then' qq=true exit do' end if end if objIE0.document.all.pinCode.value=pinCode ' password index=7 end if wscript.sleep(500) loop err.clear if qq=true then exit doloop

2009.02.14

コメント(0)
みんなのFXログインシェル作ったよVBS,WSHでのIE操作例

先頭2行をユーザid,パスワードの代入文に変更してくださいid=""pw=""Dim objIE0'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://min-fx.tv/" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://min-fx.tv/" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.loginId.value=id ' text index=0objIE0.document.all.password.value=pw ' password index=1objIE0.Document.links(0).click 'https://min-fx.tv/#

2009.02.07

コメント(0)
クレジットカード未請求買い物一覧をEXCELに取り込むVBA OMCカード

OMCカードの会員ページOMC Plus Top > ご利用明細 > 最近のご利用(未請求分)　>　詳細を見るより買い物一覧をexcelに取り込みます前提：OMC@Plus会員専用インターネットサービスのidがあること　　　　ワークシート：accountにid,パスワードがあること。Id：1行1列、パスワート：2行1列動作：”次の5件”のリンクがなくなるまでショッピングの明細をブラウズ　　　　カレントのワークシートに一覧を取り込み以下ソースですDim objIE0 As Object 'ルートのオブジェクト、操作コードではこの名称を使用しますDim objIE1 As Object, objIE2 As Object 'FRAMEのオブジェクト、ネストが3重以上になる場合は、objIE3,objIE4・・・を追加してくださいDim s As String, nn As Integer'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then If Window.Document.URL = "https://ca.omc-card.co.jp/member/omcplus_login.html" Then Set objIE0 = Window '対象URLが表示→その画面を使う win_s = True Exit For End If End IfNextIf win_s = False Then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.navigate "https://ca.omc-card.co.jp/member/omcplus_login.html" Do While objIE0.Busy = True DoEvents Loop Do While objIE0.Document.readyState <> "complete" DoEvents LoopEnd If'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.Document.all.sid_input.Value = Worksheets("account").Cells(1, 1).Value ' text index=2objIE0.Document.all.pw_input.Value = Worksheets("account").Cells(2, 1).Value ' password index=3objIE0.Document.links(0).Click 'javascript:checkInput(document.form1);Call ie_wait(objIE0)Dim meisai(6) As Stringj = 0Call link_click(objIE0, "text_inc", "ご利用代金明細照会")Call link_click(objIE0, "text_inc", "詳細を見る")s_pos = 2x = 99s = objIE0.Document.body.innerhtmlDo Until x = -1 s = strmid(s, "<TH>ご利用日</TH>", "") Do Until InStr(s, "<TD class=left>") = 0 dd = strmid(s, "<TD class=left>", "<") shop = strmid(s, "<TD class=left>", "<") gaku = strmid(s, "<TD class=right>", "<") Cells(s_pos, 1).Value = dd Cells(s_pos, 2).Value = shop Cells(s_pos, 3).Value = gaku s_pos = s_pos + 1 Loop x = link_click(objIE0, "text_inc", "次の5") s = objIE0.Document.body.innerhtmlLoop

2009.02.06

コメント(5)
新生銀行セキュリティ番号猶予期間終わってしまった→だいたい自動化できた

セキュリティ・カード受領後2週間はチェックをスルーできたのだが、今日から必須となっていた自動化は面倒かなとおもってた、だって表がでてそこの色が変わった座標を認識しないといけないじゃないでも何のことはない。表みなくても、入力boxの上に座標が表示されてるじゃんあの表って何の意味あるの?見やすいと勘違いするだけだよ。結局”A列の3行"とかカード上で確認するんだから画面の表とカードを照らし合わせるなんて絶対ないのに、つまんないとこに労力つかってんのただPopupなどまた面倒なことしやがって、こいつはsendkeyっしかダメなのかな？これ以外は解決Worksheets("account").Cells(11, 4)から5列にセキュリティの表の1行をそれぞれ設定してください画面の座標からセルの値を取り出し入力boxに代入するのを追加したよコードは下記'ここまでにログインできてて、セキュリティの画面が出てる状態 s = objIE.Document.body.innerhtml s = strmid(s, "セキュリティ・カード", "") s_key(0) = Worksheets("account").Cells(11, 4) s_key(1) = Worksheets("account").Cells(12, 4) s_key(2) = Worksheets("account").Cells(13, 4) s_key(3) = Worksheets("account").Cells(14, 4) s_key(4) = Worksheets("account").Cells(15, 4) For i = 0 To 2 s_pos = strmid(s, "<TH width=""15%"">", "<") p(i) = Mid(s_key(CInt(Right(s_pos, 1))), Asc(Left(s_pos, 1)) - 64, 1) Next For Each objTAG In objIE.Document.all Debug.Print objTAG.tagName & ":" & TypeName(objTAG) Tag = objTAG.tagName If Tag = "INPUT" Then objName = objTAG.name 'If objName = "securitykeyboard" Then objTAG.Click If objName = "fldGridChg1" Then objTAG.Value = p(0) If objName = "fldGridChg2" Then objTAG.Value = p(1) If objName = "fldGridChg3" Then objTAG.Value = p(2) If objName = "Login" Then objTAG.Click Call ie_wait(objIE) Exit For End If End If Next

2009.02.05

コメント(0)
イーバンク・ログイン生年月日自動入力

1月末くらいから、id、パスワード入力後に生年月日を入力しなければならない場合がある面倒なことに、こんなところにselectになっている・前提　Worksheets("account").Cells(2, 14).Valueに西暦で生年　Worksheets("account").Cells(2, 14).Valueに生月　Worksheets("account").Cells(2, 14).Valueに生日以下id、パスワード入力後のソースです。前後は過去のブログにありますのでそちらを訂正してください s = objIE.Document.body.innerhtml If InStr(s, "生年月日") > 0 Then objIE.Document.all.tags("SELECT").Item(0).selectedIndex = Worksheets("account").Cells(2, 14).Value - 1890 objIE.Document.all.tags("SELECT").Item(1).selectedIndex = Worksheets("account").Cells(3, 14).Value - 1 objIE.Document.all.tags("SELECT").Item(2).selectedIndex = Worksheets("account").Cells(4, 14).Value - 1 objIE.Document.all.tags("INPUT").Item(0).Click Call ie_wait(objIE) End If

2009.02.04

コメント(0)
FXマネーパートナーズのログインシェル作ったよVBS,WSHでのIE操作例

先頭2行をユーザid,パスワードの代入文に変更してくださいid=""pw=""Dim objIE0'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://www.moneypartners.co.jp/login/login.html" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://www.moneypartners.co.jp/login/login.html" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.loginId.value=id ' text index=0objIE0.document.all.password.value=pw ' password index=1objIE0.document.all.LOGIN.click ' image LOGIN or tags("INPUT").item(2).Click

2009.02.03

コメント(0)
クレジットカードの買い物一覧をEXCELに取り込むVBA OMCカード

OMCカードの会員ページOMC Plus Top > ご利用明細 > ご請求内容の明細より各月の買い物一覧をexcelに取り込みます前提：OMC@Plus会員専用インターネットサービスのidがあること　　　　ワークシート：accountにid,パスワードがあること。Id：1行1列、パスワート：2行1列動作：月ごとにご請求内容の明細をブラウズ　　　　ワークシート名として、"年_月"の規則でワークシートを追加　　　　追加したワークシートに一覧を取り込み　　　　"年_月"ワークシートがある場合その時点で止める以下ソースですSub omcLogin()Dim objIE0 As Object 'ルートのオブジェクト、操作コードではこの名称を使用しますDim objIE1 As Object, objIE2 As Object 'FRAMEのオブジェクト、ネストが3重以上になる場合は、objIE3,objIE4・・・を追加してくださいDim s As String, nn As Integer'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then If Window.Document.URL = "https://ca.omc-card.co.jp/member/omcplus_login.html" Then Set objIE0 = Window '対象URLが表示→その画面を使う win_s = True Exit For End If End IfNextIf win_s = False Then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.navigate "https://ca.omc-card.co.jp/member/omcplus_login.html" Do While objIE0.Busy = True DoEvents Loop Do While objIE0.Document.readyState <> "complete" DoEvents LoopEnd If'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.Document.all.sid_input.Value = Worksheets("account").Cells(1, 1).Value ' text index=2objIE0.Document.all.pw_input.Value = Worksheets("account").Cells(2, 1).Value ' password index=3objIE0.Document.links(0).Click 'javascript:checkInput(document.form1);Call ie_wait(objIE0)Dim meisai(6) As Stringj = 0Call link_click(objIE0, "text_inc", "ご利用代金明細照会")For i = 0 To objIE0.Document.links.Length - 1 link_s = objIE0.Document.links(i).href If InStr(link_s, "xt_details_inquiry.asp") > 0 Then meisai(j) = objIE0.Document.links(i).href j = j + 1 'objIE0.navigate objIE0.Document.links(i).href 'objIE0.Document.links(i).Click End IfNextFor i = 0 To j - 1 objIE0.navigate meisai(i) Call ie_wait(objIE0) nn = toridasi(objIE0) If nn = 0 Then Application.StatusBar = "取り込み済み" Exit For End IfNextEnd SubFunction toridasi(objIE As Object) As IntegerDim s As Stringtoridasi = 0s = objIE.Document.body.innerhtmlnen = strmid(s, "<TD id=goriyou_txt><STRONG>", "<")tuki = strmid(s, ">", "<")tuki = strmid(s, ">", "<")sheet_n = nen & "_" & tukiOn Error GoTo kekeSheets(sheet_n).ActivateGoTo enddkeke:On Error GoTo 0toridasi = toridasi + 1Set NewWS = Worksheets.Add '(After:=Worksheets("Sheet3"))With NewWS .Name = sheet_n' .Columns.ColumnWidth = 20End WithSheets(sheet_n).Activates = strmid(s, "カードショッピング", "")s_pos = 2Do Until InStr(s, "ゴシック"">") = 0 mono = strmid(s, "ゴシック"">", "<") mono = Replace(mono, ". ", ".") mono = Replace(mono, " ", " ") r = 1 sd = "" For j = 1 To Len(mono) If Mid(mono, j, 1) = " " Then If Len(sd) > 0 Then Cells(s_pos, r).Value = sd r = r + 1 sd = "" End If Else sd = sd & Mid(mono, j, 1) End If Next If Len(sd) > 0 Then Cells(s_pos, r).Value = sd s_pos = s_pos + 1 'nengetu = strmid(s, "> ", " ") 'hi = strmid(s, "", " ") 'mise = strmid(s, "", " ") 'gaku = strmid(s, "", " ")Loopendd:End FunctionFunction strmid(ByRef org As String, ByVal mae As String, ByVal usiro As String) As String 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 IfEnd FunctionFunction link_click(objIE As Object, typ As String, v As String) As Integerlink_click = -1c = 0 For i = 0 To objIE.Document.links.Length - 1 If typ = "text" Then If objIE.Document.links(i).outertext = v Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "text_inc" Then If InStr(objIE.Document.links(i).outertext, v) > 0 Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "href" Then If objIE.Document.links(i).href = v Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "href_inc" Then If InStr(objIE.Document.links(i).href, v) > 0 Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If If typ = "num" Then c = c + 1 If c = CStr(v) Then objIE.Document.links(i).Click Call ie_wait(objIE) link_click = 0 Exit For End If End If NextEnd FunctionFunction ie_wait(objIE As Object) Do While objIE.Busy = True DoEvents Loop ' Do While objIE.Document.readyState <> "complete" DoEvents LoopEnd Function

2009.01.28

コメント(0)
金沢/富山～東京帰省終電遅れで新幹線接続不可、ホテル宿泊に

1月3日19時ちょい前、金沢発北越9号滑川:前の列車点検のため12分停車～黒部で更に10分ほど遅れ泊に臨時停車、不調は一つまえの帰省形:はくたかはくたか運転打ち切り、その客を乗せ替え新幹線終電の接続は直江津以降、jr東日本の車掌が連絡するとのこと糸魚川:連絡不可のアナウンス、反対側ホームのはくたかで戻り明日やり直してくれだつて私ははくたかで帰ることにした数分後、長岡で連絡の訂正アナウンス北越に戻る直江津:やっぱり接続不可だって駅員ともめる新潟で車中宿泊、翌日の始発でかえってくれ長岡:新潟に旅館確保のアナウンス新津:0時40分頃、どんだけ遅れかな？アナウンスなし

2009.01.03

コメント(2)
クリック証券の取引暗証番号を自動入力するシェルwsh,vbs

先頭1行取引暗証番号の代入文にしてください以下ソースですpinCode="" '取引暗証番号の代入文にしてくださいDim objIE0 'ルートのオブジェクト、操作コードではこの名称を使用しますSet xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if instr(Window.Document.url,"https://kabu.click-sec.com")>0 then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextdo if instr(objIE0.document.body.innerhtml,"<INPUT class=password id=pinCode")>0 then objIE0.document.all.pinCode.value=pinCode ' password index=7 end if wscript.sleep(500)loop

2008.12.03

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

楽天ランキング市場のリンクを自分用のアフィリエイトのリンクに変更してhtmをつくるシェルですソースはこちら

2008.11.22

コメント(0)
ヤマトメール便使ってますか？お役立ちシェル紹介します

ヤマト運輸メール便集荷依頼のシェル作りました集荷依頼が・シェル起動のダブルクリック・集荷日時のラジオボタン・クリック・個数入力・次へ、確定のクリックで出来てしまいます。提携業務を自動化したいかた、VBAの勉強したい人こちらにアップしてますところで問い合わせの終了表示が2月頃から”投函完了”になりましたね。昔は”配達完了”だったと思います

2008.11.20

コメント(0)
Yahoo APIでオークション出品一覧取り込みVBA XML

前提：1行7列にYahooApiID,1行8列に一覧取得対象のYahooIDを置いてください以下ソースですDim xml As ObjectDim doc As Object, vv As ObjectDim BaseURL As String'On Error GoTo Err:Set xml = CreateObject("WinHttp.WinHttpRequest.5.1")Set doc = CreateObject("Microsoft.XMLDOM")doc.async = Falsexml.option(6) = False'url = "http://auctions.yahooapis.jp/AuctionWebService/V1/SellingList?appid=" & Cells(1, 1).Value & "&category=2084044805&new=1"url = "http://auctions.yahooapis.jp/AuctionWebService/V1/SellingList?appid=" & Cells(1, 7).Valueurl = url & "&sellerID=" & Cells(1, 8).Valuexml.Open "GET", url, Falsexml.sendDebug.Print xml.responseTextdoc.loadXML (xml.responseText)num = doc.documentElement.childnodes.LengthFor i = 1 To num - 1 'Cells(i + 1, 3).Value = doc.documentElement.childnodes.Item(i).nodeTypedValue Cells(i + 1, 1).Value = doc.documentElement.childnodes.Item(i).childnodes.Item(0).nodeTypedValue 'id Cells(i + 1, 3).Value = doc.documentElement.childnodes.Item(i).childnodes.Item(1).nodeTypedValue 'title Cells(i + 1, 2).Value = doc.documentElement.childnodes.Item(i).childnodes.Item(2).nodeTypedValue 'url Cells(i + 1, 4).Value = doc.documentElement.childnodes.Item(i).childnodes.Item(4).nodeTypedValue 'kakaku Cells(i + 1, 6).Value = doc.documentElement.childnodes.Item(i).childnodes.Item(5).nodeTypedValue 'bids Cells(i + 1, 5).Value = doc.documentElement.childnodes.Item(i).childnodes.Item(6).nodeTypedValue '終了日Next

2008.11.13

コメント(28)
かざか証券QUICK情報よりリアルタイム値を取得する関数VBS,WSH,IE操作

かざか証券のQUICK情報のIE画面があること(http://qweb15-2.qhit.net/livedoor2で始まる画面)引数objIE:かざか証券のQUICK情報のIE画面のオブジェクトを返すmeigara：検索する銘柄コードを指定するa：株価他を返す配列、a(1):現在値,a(2):前日比,他をソース参照してくださいFunction kabuka_f(objIE,meigara,a)Set objFRAME = objIE.document.framesIf InStr(objIE.document.URL, "http://qweb15-2.qhit.net") > 0 Then 'livedoor Set objDOC = objFRAME("quick_menu").document For Each objElement In objDOC.getElementsByTagName("INPUT") '現物買い If objElement.Name = "KEY1" Then objElement.Value = meigara End If If objElement.Value = "GO" Then objElement.Click Exit For End If Next Call ie_wait(objIE) Set objDOC = objFRAME("quick_main").document s = objDOC.body.innerhtml s = strmid(s, "", "売買単位") If InStr(s, "貸") > 0 Then a(12) = "貸" Else a(12) = "" End If s = objDOC.body.innerhtml s = strmid(s, "<TH class=midashi noWrap width=""60%"">", "") a(0) = strmid(s, "　", "<") '銘柄名 s = strmid(s, ">現値</TD>", "") a(1) = strmid(s, "+2>", "円") '現在値 s = strmid(s, ">前日比</TD>", "") s = strmid(s, "color=", "") a(2) = strmid(s, ">", "<") '前日比 s = strmid(s, ">売気配</TD>", "") a(4) = strmid(s, "</FONT>", "<") '売り値 a(3) = strmid(s, "color=#c61484>", "<") '売り数量 If IsNumeric(a(3)) = True Then a(3) = a(3) * 1000 Else a(3) = 0 End If s = strmid(s, ">買気配</TD>", "") a(5) = strmid(s, "</FONT>", "<") '買い値 a(6) = strmid(s, "color=#c61484>", "<") '買い数量 If IsNumeric(a(6)) = True Then a(6) = a(6) * 1000 Else a(6) = 0 End If s = strmid(s, "売買高", "") a(7) = strmid(s, "bgColor=#ffffff>", "<") '出来高 If IsNumeric(a(7)) = True Then a(7) = a(7) * 1000 Else a(7) = 0 End If For i = 1 To 8 If IsNumeric(a(i)) = True Then Else a(i) = 0 End If Next a(8) = CLng(a(1)) - CLng(a(2)) 'strmid(s, "", "<") '前日終値 s = strmid(s, "始値", "") a(9) = strmid(s, "bgColor=#ffffff>", "<") '始値 s = strmid(s, "高値", "") a(10) = strmid(s, "/FONT>", "<") '高値 s = strmid(s, "安値", "") a(11) = strmid(s, "/FONT>", "<") '安値 For i = 9 To 11 If IsNumeric(a(i)) = True Then Else a(i) = 0 End If NextElse 'kyouei Set objDOC = objFRAME("LM").document For Each objElement In objDOC.getElementsByTagName("IMG") '現物買い If objElement.alt = "現物買" Then objElement.Click Exit For End If Next Call ie_wait(objIE) Set objFRAME = objIE.document.frames Set objDOC = objFRAME("CT").document For Each objElement In objDOC.getElementsByTagName("INPUT") '現物買い If objElement.Name = "dscrCDsearch" Then objElement.Value = meigara set_m = True End If If objElement.Name = "list" Then objElement.Click Exit For End If Next Call ie_wait(objIE) s = objDOC.body.innerhtml ss = objDOC.body.outertext s = strmid(s, "<TD class=labelBlue>銘柄名</TD>", "") a(0) = strmid(s, "dscr>", "<") 'If InStr(s, "銘柄名をご確認のうえ、口座区分、市場、株数、値段、執行条件を入力し") = 0 Then ' Sleep 200' GoTo retry2'End If sss = "現在値" ss = Right(ss, Len(ss) - (InStr(ss, sss) + Len(sss)) + 1) s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) 's = Left(s, InStr(s, "<") - 1) sss = "<TD class=labelWhite>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(1) = Left(s, InStr(s, "<") - 1) '現在値 sss = "<FONT class=" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = ">" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(2) = Left(s, InStr(s, "<") - 1) '前日比 sss = "<TD>売数量(" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = "<TD class=labelWhite>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(3) = Left(s, InStr(s, "<") - 1) '売り数量 sss = "<TD class=bg" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = ">" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(4) = Replace(Left(s, InStr(s, "<") - 1), " ", "") '売り値 sss = "<TD class=bg" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = ">" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(5) = Replace(Left(s, InStr(s, "<") - 1), " ", "") '買い値 sss = "<TD class=labelWhite>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(6) = Left(s, InStr(s, "<") - 1) '買い数量 sss = "<TD class=labelWhite align=right>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(7) = Left(s, InStr(s, "<") - 1) '出来高 sss = "<TD class=labelWhite align=right>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = "<TD class=labelWhite align=right>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(8) = Left(s, InStr(s, "<") - 1) '前日終値 sss = "始値" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = "<TD class=labelWhite align=right>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(9) = Left(s, InStr(s, "<") - 1) '始値 sss = "高値" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = "<TD class=labelWhite align=right>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(10) = Left(s, InStr(s, "<") - 1) '高値 sss = "安値" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) sss = "<TD class=labelWhite align=right>" s = Right(s, Len(s) - (InStr(s, sss) + Len(sss)) + 1) a(11) = Left(s, InStr(s, "<") - 1) '安値End IfEnd FunctionFunction 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 IfEnd FunctionFunction ie_wait (objIE) Do While objIE.busy Loop Do While objIE.Document.readyState <> "complete" Loop'if MsgBox("nuke " & Timer & " " & s_t, VbOKCancel, "WS") = vbOK Then WScript.QuitEnd function

2008.11.13

コメント(0)
クリック証券の株式売買を自前の画面で、カスタマイズみたいシェルVBS,WSHでのIE操作例

クリック証券の株式売買用の自前シェルです。注文時の暗証番号入力、反対注文の株数入力、画面の切り替えなどを省略できます'保有株、信用建玉を8行表示、反対売買の単価を"決済単価”に入力”注文”のチェックをクリックで発注します'注文中を8表示、”変更単価”に入力”変更”のチェックボックスをクリックで変更発注。"取消”のチェックボックスのクリックで取消注文を出します'現物余力、信用余力、保証金維持率の表示'新規注文の行：銘柄コード、買い・信用、数量、単価、取引所を入力、"注文”のチェックボックスをクリックで発注します'確認画面とかありません。暗証番号の入力もありません'反対注文のとき対応する取引所を新規注文の行から指定してください。apiに主市場の指定ができるといいんですけど’1秒単位で画面を更新します。この単位も1箇所sleep(1000)の変更でいけます'先頭2行を五字分のユーザid,パスワードの代入文に変更してくださいソースはこちら

2008.11.11

コメント(0)
クリック証券保有株信用建玉一覧表示シェルVBS,WSHでのIE操作例

先頭2行をユーザid,パスワードの代入文に変更してください5秒毎に更新します最大10行にしてあります、変更する場合、変数rtの最初の代入文をその行数にしてくださいuid = ""passwd = ""n=""dim xml,doc,BaseURLSet objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100Looprenpai=0sonekiT=0Tnum=0Ynum=0Knum=0Lnum=0rt=10retu=14objIEx.Width=600objIEx.Height=700objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "<table>"objIEx.Document.Write "<tr><td>種別</td><td>注文</td><td>コード</td><td>信用区分</td><td>信用市場</td><td>口座区分</td><td>信用区分</td><td>数量</td><td>注文中数量</td><td>信用建日</td><td>返済期日</td><td>単価</td><td>信用経費</td><td>信用利息</td></tr>"for i= 0 to rt-1 objIEx.Document.Write "<tr>" for j=0 to retu-1 objIEx.Document.Write "<td>" objIEx.Document.Write "<input size=3 type=input name=f" & cstr(i) & "_" & cstr(j) & "></td>" next objIEx.Document.Write "</tr>"nextobjIEx.Document.Write "</table>"objIEx.Document.Write "停止:<input type=checkbox name=term><br>"Set XML = CreateObject("WinHttp.WinHttpRequest.5.1")Set doc = CreateObject("Microsoft.XMLDOM")doc.async = FalseXML.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせないURL = "https://sec-sso.click-sec.com/webservice/ws-redirect?u=" & uidXML.Open "GET", URL, FalseXML.sendLocation = XML.getResponseHeader("Location") 'リダイレクト先URLの取得aa = InStr(Len("https://") + 1, Location, "/") 'https://kabu.click-sec.com/ の文字列数bb = InStr(aa + 1, Location, "/") 'https://kabu.click-sec.com/sec1-6/ の文字列数BaseURL = Left(XML.getResponseHeader("Location"), bb - 1)XML.option(6) = True '6=WinHttpRequestOption_EnableRedirects URL = LocationXML.Open "GET", URL, FalseXML.senddoc.loadXML (XML.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側エラー " + msg wscript.quitEnd If'シーケンス３ユーザ認証とリダイレクトでURLをたどっていくURL = BaseURL & "/ws-login?j_username=" & uid & "&j_password=" & passwdXML.Open "GET", URL, FalseXML.senddoc.loadXML (XML.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then MsgBox ("ユーザIDまたはパスワードが誤っています") wscript.quit ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then MsgBox ("GMOホームページに行って利用設定が必要です") wscript.quitElse msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMOエラー " + msg wscript.quitEnd IfElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMOエラー " + msg wscript.quitEnd IfobjIEx.Document.Write "Login完了<br>"do URL = BaseURL & "/ws/kabu/hoyukabuTategyokuList.do?lst=3" XML.Open "GET", URL, False XML.send doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue msgbox "GMOエラー "& msg & "<br>" End If Set ListItems = doc.documentElement.selectSingleNode("hoyukabuTategyokuList").childNodes ii = 0 Do While ii < ListItems.Length And ii < rt Set ListItem = ListItems.Item(ii) if ListItem.selectSingleNode("shubetsu").nodeTypedValue="1" then v="現物" else v="信用" end if objIEx.document.all.tags("INPUT").item(ii*retu+0).value = v if ListItem.selectSingleNode("chumonKano").nodeTypedValue="" then else if ListItem.selectSingleNode("chumonKano").nodeTypedValue="0" then v="不可" else v="可能" end if objIEx.document.all.tags("INPUT").item(ii*retu+1).value = v end if objIEx.document.all.tags("INPUT").item(ii*retu+2).value = ListItem.selectSingleNode("meigara").Attributes.getNamedItem("shokenCode").nodeTypedValue if ListItem.selectSingleNode("baibai").nodeTypedValue="" then else if ListItem.selectSingleNode("baibai").nodeTypedValue="1" then v="売" else v="買" end if objIEx.document.all.tags("INPUT").item(ii*retu+3).value = v end if if ListItem.selectSingleNode("shijo").nodeTypedValue="" then else if ListItem.selectSingleNode("shijo").nodeTypedValue="001" then v="東証" elseif ListItem.selectSingleNode("shijo").nodeTypedValue="002" then v="大証" elseif ListItem.selectSingleNode("shijo").nodeTypedValue="006" then v="JASDAQ" elseif ListItem.selectSingleNode("shijo").nodeTypedValue="007" then v="ヘラクレス" end if objIEx.document.all.tags("INPUT").item(ii*retu+4).value = v end if if ListItem.selectSingleNode("koza").nodeTypedValue="1" then v="一般" else v="特定" end if objIEx.document.all.tags("INPUT").item(ii*retu+5).value = v if ListItem.selectSingleNode("shinyo").nodeTypedValue="0" then v="非信用" elseif ListItem.selectSingleNode("shinyo").nodeTypedValue="1" then v="制度" elseif ListItem.selectSingleNode("shinyo").nodeTypedValue="2" then v="一般" end if objIEx.document.all.tags("INPUT").item(ii*retu+6).value = v objIEx.document.all.tags("INPUT").item(ii*retu+7).value = ListItem.selectSingleNode("suryo").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*retu+8).value = ListItem.selectSingleNode("chumonSuryo").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*retu+9).value = ListItem.selectSingleNode("tatebi").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*retu+10).value = ListItem.selectSingleNode("hensaiKijitsu").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*retu+11).value = ListItem.selectSingleNode("tanka").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*retu+12).value = ListItem.selectSingleNode("shiharaiShokeihi").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*retu+13).value = ListItem.selectSingleNode("uketoriRisoku").nodeTypedValue 'objIEx.document.all.tags("INPUT").item(ii*retu+14).value = "'" & ListItem.selectSingleNode("tategyokuKey").nodeTypedValue ii = ii + 1 Loop for iii=ii to rt-1 '空欄クリア for j=0 to retu-1 objIEx.document.all.tags("INPUT").item(iii*retu+j).value="" next next if objIEx.Document.all.term.checked=true then exit do wscript.sleep(5000)loopset_pos = 2uri_torikomi = 0kai_torikomi = 0uri_c = 0kai_c = 0sin_uri_torikomi = 0sin_kai_torikomi = 0sin_uri_c = 0sin_kai_c = 0doc.async = False '非同期をやめる。つまり同期にする。url = BaseURL & "/ws-logout"xml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msgbox "GMOエラー "& msg & "<br>"End IfSet xml = NothingSet doc = NothingobjIEx.Document.Write "Logout完了"

2008.11.09

コメント(0)
クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました

クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りましたこちらのサイトからログイン、約定一覧取得などキモ部分をまるまるコピーしました。ありがとうございます＜前提＞accountの名前のシートにユーザid,パスワードを置くことCells(2, 10).Value　ユーザidCells(3, 10).Value　パスワード＜取り込み仕様＞1列:受渡日2列:銘柄コード3列:売買区分4列:約定数量5列:約定単価6列:受渡額7列:手数料10列:受付番号＜困った事、返答してくれない項目がある＞1)手数料、信用の諸経費現物は受け渡し額・単価・数で計算できるが、信用は対応する新規約定と突き合せないとわからない→私の場合約定毎なので150円固定値にした。1日定額の方は、150円を0円に変更していただき、取り込み後に任意の行に手数料をセットしてください。1つのセルだけの操作でいけるはずです諸経費はどうでもいいや。決済の額で損得計算できるから。そういう意味では手数料もどうでもいい2)銘柄名手で入力してください。ex:アイオーデータ[6916]の”アイオーデータ”は手で入力ただし既に取り込んだ分をコードでサーチするようにしてあります。見つけた場合は銘柄名[コード]の形でセットします以下ソースですuid = Worksheets("account").Cells(2, 10).Valuepasswd = Worksheets("account").Cells(3, 10).Value On Error GoTo Err: With ActiveWorkbook.Worksheets(ActiveWorkbook.ActiveSheet.Name) 行 = 5 Set XML = CreateObject("WinHttp.WinHttpRequest.5.1") Set doc = CreateObject("Microsoft.XMLDOM") doc.async = False XML.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせない URL = "https://sec-sso.click-sec.com/webservice/ws-redirect?u=" & uid '2008/03/29 URL変更 XML.Open "GET", URL, False XML.send Location = XML.getResponseHeader("Location") 'リダイレクト先URLの取得 aa = InStr(Len("https://") + 1, Location, "/") 'https://kabu.click-sec.com/ の文字列数 bb = InStr(aa + 1, Location, "/") 'https://kabu.click-sec.com/sec1-6/ の文字列数基底URL = Left(XML.getResponseHeader("Location"), bb - 1) XML.option(6) = True '6=WinHttpRequestOption_EnableRedirects URL = Location XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End If 'シーケンス３ユーザ認証とリダイレクトでURLをたどっていく URL = 基底URL & "/ws-login?j_username=" & uid & "&j_password=" & passwd XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then MsgBox ("ユーザIDまたはパスワードが誤っています") Exit Sub ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then MsgBox ("GMOホームページに行って利用設定が必要です") Exit Sub Else msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End If ElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End IfApplication.StatusBar = "Login完了"set_pos = 2uri_torikomi = 0kai_torikomi = 0uri_c = 0kai_c = 0sin_uri_torikomi = 0sin_kai_torikomi = 0sin_uri_c = 0sin_kai_c = 0 doc.async = False URL = 基底URL & "/ws/kabu/kabuYakujoList.do" XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue Application.StatusBar = "GMOエラー " & msg Exit Sub End IfSet ListItems = doc.documentElement.selectSingleNode("yakujoList").childNodesYakuNum = ListItems.LengthYakuNum_Sumi = YakuNumFor ii = 0 To YakuNum - 1Set ListItem = ListItems.Item(ii)' cmp_str = yakuteihi & m_name & "[" & m_code & "]" & syubetu & yakutei_no 'cmp_str = Replace(cmp_str, ",", "")uketuke_no_w = CStr(ListItem.selectSingleNode("chumonBango").nodeTypedValue)Set FoundCell = Range("j2", "j65536").Find(uketuke_no_w)If FoundCell Is Nothing Then YakuNum_Sumi = YakuNum_Sumi - 1 scode = ListItem.selectSingleNode("meigara").Attributes.getNamedItem("shokenCode").nodeTypedValue Set FoundCell = Range("b2", "b65536").Find(scode) If FoundCell Is Nothing Then m_name = "[" & scode & "]" Else m_name = FoundCell.Value End If ' If f = True Then Rows(CStr(set_pos) & ":" & CStr(set_pos)).Select Selection.Insert Shift:=xlDow Cells(set_pos, 1).Value = Replace(ListItem.selectSingleNode("ukewatashiBi").nodeTypedValue, "-", "/") Cells(set_pos, 2).Value = m_nameIf ListItem.selectSingleNode("baibai").nodeTypedValue = "2" Then syubetu = "買"Else syubetu = "売"End IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "22" Then syubetu = "返済" & syubetuEnd IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "21" Then syubetu = "信用" & syubetuEnd IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "23" Then If syubetu = "買" Then syubetu = "現引" Else syubetu = "現渡" End IfEnd IfIf InStr(syubetu, "現渡") > 0 Or InStr(syubetu, "現引") > 0 ThenElse If InStr(syubetu, "信用") = 0 Then If InStr(syubetu, "買") > 0 Then kai_c = kai_c + 1 Else uri_c = uri_c + 1 End If Else If InStr(syubetu, "買") > 0 Then sin_kai_c = sin_kai_c + 1 Else sin_uri_c = sin_uri_c + 1 End If End IfEnd If Cells(set_pos, 3).Value = syubetu yakujoSuryo = ListItem.selectSingleNode("yakujoSuryo").nodeTypedValue Cells(set_pos, 4).Value = yakujoSuryo yakujoTanka = ListItem.selectSingleNode("yakujoTanka").nodeTypedValue Cells(set_pos, 5).Value = yakujoTanka ukewatashiDaikin = ListItem.selectSingleNode("ukewatashiDaikin").nodeTypedValue Cells(set_pos, 6).Value = ukewatashiDaikin Cells(set_pos, 9).Value = 0 'yakutei_no Cells(set_pos, 10).Value = CStr(uketuke_no_w) 'uketuke_no(ii) fee = 150 If syubetu = "買" Then kai_torikomi = kai_torikomi + 1 If ukewatashiDaikin "" Then fee = (-1 * ukewatashiDaikin) - (yakujoSuryo * yakujoTanka) End If ElseIf syubetu = "売" Then uri_torikomi = uri_torikomi + 1 fee = yakujoSuryo * yakujoTanka - ukewatashiDaikin ElseIf syubetu = "返済売" Then sin_uri_torikomi = sin_uri_torikomi + 1 ElseIf syubetu = "返済買" Then sin_kai_torikomi = sin_kai_torikomi + 1 End If Cells(set_pos, 7).Value = fee set_pos = set_pos + 1 End If Next End With Application.StatusBar = "約定数=" & YakuNum & " 取込済=" & YakuNum_Sumi & " 売り取込=" & uri_torikomi & " 買い取込=" & kai_torikomi & " 売り取込済=" & uri_c - uri_torikomi & " 買い取込済=" & kai_c - kai_torikomi & _"信用売り取込=" & sin_uri_torikomi & " 信用買い取込=" & sin_kai_torikomi & " 信用売り取込済=" & sin_uri_c - sin_uri_torikomi & " 信用買い取込済=" & sin_kai_c - sin_kai_torikomidoc.async = FalseURL = 基底URL & "/ws-logout"XML.Open "GET", URL, FalseXML.senddoc.loadXML (XML.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then GoTo Err:End IfSet XML = NothingSet doc = NothingExit SubErr:Application.StatusBar = "エラーが発生しました" + vbCrLf + Err.Description

2008.11.07

コメント(1)
クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました

クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りましたこちらのサイトからログイン、約定一覧取得などキモ部分をまるまるコピーしました。ありがとうございます＜前提＞accountの名前のシートにユーザid,パスワードを置くことCells(2, 10).Value　ユーザidCells(3, 10).Value　パスワード＜取り込み仕様＞1列:受渡日2列:銘柄コード3列:売買区分4列:約定数量5列:約定単価6列:受渡額7列:手数料10列:受付番号＜困った事、返答してくれない項目がある＞1)手数料、信用の諸経費現物は受け渡し額・単価・数で計算できるが、信用は対応する新規約定と突き合せないとわからない→私の場合約定毎なので150円固定値にした。1日定額の方は、150円を0円に変更していただき、取り込み後に任意の行に手数料をセットしてください。1つのセルだけの操作でいけるはずです諸経費はどうでもいいや。決済の額で損得計算できるから。そういう意味では手数料もどうでもいい2)銘柄名手で入力してください。ex:アイオーデータ[6916]の”アイオーデータ”は手で入力ただし既に取り込んだ分をコードでサーチするようにしてあります。見つけた場合は銘柄名[コード]の形でセットします以下ソースですuid = Worksheets("account").Cells(2, 10).Valuepasswd = Worksheets("account").Cells(3, 10).Value On Error GoTo Err: With ActiveWorkbook.Worksheets(ActiveWorkbook.ActiveSheet.Name) 行 = 5 Set XML = CreateObject("WinHttp.WinHttpRequest.5.1") Set doc = CreateObject("Microsoft.XMLDOM") doc.async = False XML.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせない URL = "https://sec-sso.click-sec.com/webservice/ws-redirect?u=" & uid '2008/03/29 URL変更 XML.Open "GET", URL, False XML.send Location = XML.getResponseHeader("Location") 'リダイレクト先URLの取得 aa = InStr(Len("https://") + 1, Location, "/") 'https://kabu.click-sec.com/ の文字列数 bb = InStr(aa + 1, Location, "/") 'https://kabu.click-sec.com/sec1-6/ の文字列数基底URL = Left(XML.getResponseHeader("Location"), bb - 1) XML.option(6) = True '6=WinHttpRequestOption_EnableRedirects URL = Location XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End If 'シーケンス３ユーザ認証とリダイレクトでURLをたどっていく URL = 基底URL & "/ws-login?j_username=" & uid & "&j_password=" & passwd XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then MsgBox ("ユーザIDまたはパスワードが誤っています") Exit Sub ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then MsgBox ("GMOホームページに行って利用設定が必要です") Exit Sub Else msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End If ElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End IfApplication.StatusBar = "Login完了"set_pos = 2uri_torikomi = 0kai_torikomi = 0uri_c = 0kai_c = 0sin_uri_torikomi = 0sin_kai_torikomi = 0sin_uri_c = 0sin_kai_c = 0 doc.async = False URL = 基底URL & "/ws/kabu/kabuYakujoList.do" XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue Application.StatusBar = "GMOエラー " & msg Exit Sub End IfSet ListItems = doc.documentElement.selectSingleNode("yakujoList").childNodesYakuNum = ListItems.LengthYakuNum_Sumi = YakuNumFor ii = 0 To YakuNum - 1Set ListItem = ListItems.Item(ii)' cmp_str = yakuteihi & m_name & "[" & m_code & "]" & syubetu & yakutei_no 'cmp_str = Replace(cmp_str, ",", "")uketuke_no_w = CStr(ListItem.selectSingleNode("chumonBango").nodeTypedValue)Set FoundCell = Range("j2", "j65536").Find(uketuke_no_w)If FoundCell Is Nothing Then YakuNum_Sumi = YakuNum_Sumi - 1 scode = ListItem.selectSingleNode("meigara").Attributes.getNamedItem("shokenCode").nodeTypedValue Set FoundCell = Range("b2", "b65536").Find(scode) If FoundCell Is Nothing Then m_name = "[" & scode & "]" Else m_name = FoundCell.Value End If ' If f = True Then Rows(CStr(set_pos) & ":" & CStr(set_pos)).Select Selection.Insert Shift:=xlDow Cells(set_pos, 1).Value = Replace(ListItem.selectSingleNode("ukewatashiBi").nodeTypedValue, "-", "/") Cells(set_pos, 2).Value = m_nameIf ListItem.selectSingleNode("baibai").nodeTypedValue = "2" Then syubetu = "買"Else syubetu = "売"End IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "22" Then syubetu = "返済" & syubetuEnd IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "21" Then syubetu = "信用" & syubetuEnd IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "23" Then If syubetu = "買" Then syubetu = "現引" Else syubetu = "現渡" End IfEnd IfIf InStr(syubetu, "現渡") > 0 Or InStr(syubetu, "現引") > 0 ThenElse If InStr(syubetu, "信用") = 0 Then If InStr(syubetu, "買") > 0 Then kai_c = kai_c + 1 Else uri_c = uri_c + 1 End If Else If InStr(syubetu, "買") > 0 Then sin_kai_c = sin_kai_c + 1 Else sin_uri_c = sin_uri_c + 1 End If End IfEnd If Cells(set_pos, 3).Value = syubetu yakujoSuryo = ListItem.selectSingleNode("yakujoSuryo").nodeTypedValue Cells(set_pos, 4).Value = yakujoSuryo yakujoTanka = ListItem.selectSingleNode("yakujoTanka").nodeTypedValue Cells(set_pos, 5).Value = yakujoTanka ukewatashiDaikin = ListItem.selectSingleNode("ukewatashiDaikin").nodeTypedValue Cells(set_pos, 6).Value = ukewatashiDaikin Cells(set_pos, 9).Value = 0 'yakutei_no Cells(set_pos, 10).Value = CStr(uketuke_no_w) 'uketuke_no(ii) fee = 150 If syubetu = "買" Then kai_torikomi = kai_torikomi + 1 If ukewatashiDaikin "" Then fee = (-1 * ukewatashiDaikin) - (yakujoSuryo * yakujoTanka) End If ElseIf syubetu = "売" Then uri_torikomi = uri_torikomi + 1 fee = yakujoSuryo * yakujoTanka - ukewatashiDaikin ElseIf syubetu = "返済売" Then sin_uri_torikomi = sin_uri_torikomi + 1 ElseIf syubetu = "返済買" Then sin_kai_torikomi = sin_kai_torikomi + 1 End If Cells(set_pos, 7).Value = fee set_pos = set_pos + 1 End If Next End With Application.StatusBar = "約定数=" & YakuNum & " 取込済=" & YakuNum_Sumi & " 売り取込=" & uri_torikomi & " 買い取込=" & kai_torikomi & " 売り取込済=" & uri_c - uri_torikomi & " 買い取込済=" & kai_c - kai_torikomi & _"信用売り取込=" & sin_uri_torikomi & " 信用買い取込=" & sin_kai_torikomi & " 信用売り取込済=" & sin_uri_c - sin_uri_torikomi & " 信用買い取込済=" & sin_kai_c - sin_kai_torikomidoc.async = FalseURL = 基底URL & "/ws-logout"XML.Open "GET", URL, FalseXML.senddoc.loadXML (XML.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then GoTo Err:End IfSet XML = NothingSet doc = NothingExit SubErr:Application.StatusBar = "エラーが発生しました" + vbCrLf + Err.Description

2008.11.07

コメント(0)
クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました

クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りましたこちらのサイトからログイン、約定一覧取得などキモ部分をまるまるコピーしました。ありがとうございます＜前提＞accountの名前のシートにユーザid,パスワードを置くことCells(2, 10).Value　ユーザidCells(3, 10).Value　パスワード＜取り込み仕様＞1列:受渡日2列:銘柄コード3列:売買区分4列:約定数量5列:約定単価6列:受渡額7列:手数料10列:受付番号＜困った事、返答してくれない項目がある＞1)手数料、信用の諸経費現物は受け渡し額・単価・数で計算できるが、信用は対応する新規約定と突き合せないとわからない→私の場合約定毎なので150円固定値にした。1日定額の方は、150円を0円に変更していただき、取り込み後に任意の行に手数料をセットしてください。1つのセルだけの操作でいけるはずです諸経費はどうでもいいや。決済の額で損得計算できるから。そういう意味では手数料もどうでもいい2)銘柄名手で入力してください。ex:アイオーデータ[6916]の”アイオーデータ”は手で入力ただし既に取り込んだ分をコードでサーチするようにしてあります。見つけた場合は銘柄名[コード]の形でセットします以下ソースですuid = Worksheets("account").Cells(2, 10).Valuepasswd = Worksheets("account").Cells(3, 10).Value On Error GoTo Err: With ActiveWorkbook.Worksheets(ActiveWorkbook.ActiveSheet.Name) 行 = 5 Set XML = CreateObject("WinHttp.WinHttpRequest.5.1") Set doc = CreateObject("Microsoft.XMLDOM") doc.async = False XML.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせない URL = "https://sec-sso.click-sec.com/webservice/ws-redirect?u=" & uid '2008/03/29 URL変更 XML.Open "GET", URL, False XML.send Location = XML.getResponseHeader("Location") 'リダイレクト先URLの取得 aa = InStr(Len("https://") + 1, Location, "/") 'https://kabu.click-sec.com/ の文字列数 bb = InStr(aa + 1, Location, "/") 'https://kabu.click-sec.com/sec1-6/ の文字列数基底URL = Left(XML.getResponseHeader("Location"), bb - 1) XML.option(6) = True '6=WinHttpRequestOption_EnableRedirects URL = Location XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End If 'シーケンス３ユーザ認証とリダイレクトでURLをたどっていく URL = 基底URL & "/ws-login?j_username=" & uid & "&j_password=" & passwd XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then MsgBox ("ユーザIDまたはパスワードが誤っています") Exit Sub ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then MsgBox ("GMOホームページに行って利用設定が必要です") Exit Sub Else msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End If ElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Exit Sub End IfApplication.StatusBar = "Login完了"set_pos = 2uri_torikomi = 0kai_torikomi = 0uri_c = 0kai_c = 0sin_uri_torikomi = 0sin_kai_torikomi = 0sin_uri_c = 0sin_kai_c = 0 doc.async = False URL = 基底URL & "/ws/kabu/kabuYakujoList.do" XML.Open "GET", URL, False XML.send Debug.Print XML.responseText doc.loadXML (XML.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue Application.StatusBar = "GMOエラー " & msg Exit Sub End IfSet ListItems = doc.documentElement.selectSingleNode("yakujoList").childNodesYakuNum = ListItems.LengthYakuNum_Sumi = YakuNumFor ii = 0 To YakuNum - 1Set ListItem = ListItems.Item(ii)' cmp_str = yakuteihi & m_name & "[" & m_code & "]" & syubetu & yakutei_no 'cmp_str = Replace(cmp_str, ",", "")uketuke_no_w = CStr(ListItem.selectSingleNode("chumonBango").nodeTypedValue)Set FoundCell = Range("j2", "j65536").Find(uketuke_no_w)If FoundCell Is Nothing Then YakuNum_Sumi = YakuNum_Sumi - 1 scode = ListItem.selectSingleNode("meigara").Attributes.getNamedItem("shokenCode").nodeTypedValue Set FoundCell = Range("b2", "b65536").Find(scode) If FoundCell Is Nothing Then m_name = "[" & scode & "]" Else m_name = FoundCell.Value End If ' If f = True Then Rows(CStr(set_pos) & ":" & CStr(set_pos)).Select Selection.Insert Shift:=xlDow Cells(set_pos, 1).Value = Replace(ListItem.selectSingleNode("ukewatashiBi").nodeTypedValue, "-", "/") Cells(set_pos, 2).Value = m_nameIf ListItem.selectSingleNode("baibai").nodeTypedValue = "2" Then syubetu = "買"Else syubetu = "売"End IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "22" Then syubetu = "返済" & syubetuEnd IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "21" Then syubetu = "信用" & syubetuEnd IfIf ListItem.selectSingleNode("torihiki").nodeTypedValue = "23" Then If syubetu = "買" Then syubetu = "現引" Else syubetu = "現渡" End IfEnd IfIf InStr(syubetu, "現渡") > 0 Or InStr(syubetu, "現引") > 0 ThenElse If InStr(syubetu, "信用") = 0 Then If InStr(syubetu, "買") > 0 Then kai_c = kai_c + 1 Else uri_c = uri_c + 1 End If Else If InStr(syubetu, "買") > 0 Then sin_kai_c = sin_kai_c + 1 Else sin_uri_c = sin_uri_c + 1 End If End IfEnd If Cells(set_pos, 3).Value = syubetu yakujoSuryo = ListItem.selectSingleNode("yakujoSuryo").nodeTypedValue Cells(set_pos, 4).Value = yakujoSuryo yakujoTanka = ListItem.selectSingleNode("yakujoTanka").nodeTypedValue Cells(set_pos, 5).Value = yakujoTanka ukewatashiDaikin = ListItem.selectSingleNode("ukewatashiDaikin").nodeTypedValue Cells(set_pos, 6).Value = ukewatashiDaikin Cells(set_pos, 9).Value = 0 'yakutei_no Cells(set_pos, 10).Value = CStr(uketuke_no_w) 'uketuke_no(ii) fee = 150 If syubetu = "買" Then kai_torikomi = kai_torikomi + 1 If ukewatashiDaikin "" Then fee = (-1 * ukewatashiDaikin) - (yakujoSuryo * yakujoTanka) End If ElseIf syubetu = "売" Then uri_torikomi = uri_torikomi + 1 fee = yakujoSuryo * yakujoTanka - ukewatashiDaikin ElseIf syubetu = "返済売" Then sin_uri_torikomi = sin_uri_torikomi + 1 ElseIf syubetu = "返済買" Then sin_kai_torikomi = sin_kai_torikomi + 1 End If Cells(set_pos, 7).Value = fee set_pos = set_pos + 1 End If Next End With Application.StatusBar = "約定数=" & YakuNum & " 取込済=" & YakuNum_Sumi & " 売り取込=" & uri_torikomi & " 買い取込=" & kai_torikomi & " 売り取込済=" & uri_c - uri_torikomi & " 買い取込済=" & kai_c - kai_torikomi & _"信用売り取込=" & sin_uri_torikomi & " 信用買い取込=" & sin_kai_torikomi & " 信用売り取込済=" & sin_uri_c - sin_uri_torikomi & " 信用買い取込済=" & sin_kai_c - sin_kai_torikomidoc.async = FalseURL = 基底URL & "/ws-logout"XML.Open "GET", URL, FalseXML.senddoc.loadXML (XML.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue "OK" Then GoTo Err:End IfSet XML = NothingSet doc = NothingExit SubErr:Application.StatusBar = "エラーが発生しました" + vbCrLf + Err.Description

2008.11.07

コメント(0)
FX投資クリック証券約定読み上げシェルVBS,WSHでのIE操作例

5秒毎に約定照会し、約定があった場合、番号を読み上げます以下ソースです。先頭2行をユーザid、パスワードの代入文に変更してくださいuid=""passwd=""dim xml,doc,BaseURL,ask(99),bid(99),code(99),tsukaPairName(99),YakujyoBango(999)YakujyoNum=0YakujyoSumi=0Set objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100LoopSet xml = CreateObject("WinHttp.WinHttpRequest.5.1")Set doc = CreateObject("Microsoft.XMLDOM")call login(xml,doc,BaseURL,uid,passwd)rt=GetTsukaPairName(xml,doc,BaseURL,tsukaPairName)objIEx.Width=600objIEx.Height=700objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "<table>"objIEx.Document.Write "<tr><td>通貨ベア</td><td>Bid</td><td>Ask</td></tr>"for i= 0 to rt-1 objIEx.Document.Write "<tr>" for j=0 to 2 objIEx.Document.Write "<td>" if j=0 then objIEx.Document.Write tsukaPairName(i) & "</td>" else objIEx.Document.Write "<input size=3 type=input name=f" & cstr(i) & "_" & cstr(j) & "></td>" end if next objIEx.Document.Write "</tr>"nextobjIEx.Document.Write "</table>"objIEx.Document.Write "URL<input type=input size=60 name=url><br>"objIEx.Document.Write "エラー<input type=input size=60 name=errM><br>"objIEx.Document.Write "状態<input type=input size=60 name=stat><br>"objIEx.Document.Write "約定待ち間隔秒数(5秒以上にしてください)<input type=input size=2 name=Kankaku value=""5""><br>"objIEx.Document.Write "停止:<input type=checkbox name=term><br>"Set Voice1 = CreateObject("SAPI.SpVoice")do i=GetRate(xml,doc,BaseURL,ask,bid) for ii= 0 to i-1 objIEx.document.all.tags("INPUT").item(ii*2+1).value =ask(ii) objIEx.document.all.tags("INPUT").item(ii*2+0).value =bid(ii) next PreDate=Now objIEx.document.all.stat.value="約定照会中 " & now yakujyo=yakujyoChk(xml,dom,BaseURL,YakujyoBango,YakujyoNum) objIEx.document.all.stat.value="約定番号読み上げ中総数=" & YakujyoNum & " 読み上げ済み数=" & YakujyoSumi & " " & now if YakujyoNum>YakujyoSumi then for i=YakujyoSumi to YakujyoNum-1 Voice1.Speak YakujyoBango(i) objIEx.document.all.stat.value="約定番号読み上げ中総数=" & YakujyoNum & " 読み上げ済み数=" & i+1 & " " & now next YakujyoSumi=YakujyoNum end if objIEx.document.all.stat.value="待ち " & now if objIEx.Document.all.term.checked=true then exit do do until datediff("s",PreDate,now)>=cint(objIEx.Document.all.Kankaku.value) wscript.sleep(1000) looploopdoc.async = False '非同期をやめる。つまり同期にする。url = BaseURL & "/ws-logout"xml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then objIEx.Document.write "logout error" else objIEx.Document.write "logout OK"End IfSet xml = NothingSet doc = Nothingfunction GetTsukaPairName(xml,doc,BaseURL,tsukaPairName)doc.async = False url = BaseURL & "/ws/fx/tsukaPairList.do"xml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" End IfSet ListItems = doc.documentElement.selectSingleNode("tsukaPairList").childNodesfor ii =0 to ListItems.Length-1 Set ListItem = ListItems.Item(ii) tsukaPairName(ii)=ListItem.Attributes.getNamedItem("tsukaPairName").nodeTypedValuenextGetTsukaPairName=iiend functionfunction GetRate(xml,doc,BaseURL,ask,bid)doc.async = False url = BaseURL & "/ws/fx/rateList.do"xml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" End IfSet ListItems = doc.documentElement.selectSingleNode("rateList").childNodes for ii=0 to ListItems.Length-1 Set ListItem = ListItems.Item(ii) 'code(ii)=ListItem.Attributes.getNamedItem("tsukaPairCode").nodeTypedValue ask(ii)=ListItem.selectSingleNode("ask").nodeTypedValue bid(ii)=ListItem.selectSingleNode("bid").nodeTypedValue nextGetRate=iiend functionsub cancel(objIEx,xml,doc,baseUrl,bango)doc.async = False '非同期をやめる。つまり同期にする。url = baseUrl & "/ws/kabu/kabuChumonTorikeshi.do?"url = url & "cmk=" & bangoxml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" Wscript.quit End If msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write msgend subfunction yakujyoChk(xml,dom,BaseURL,YakujyoBango,YakujyoNum) YakujyoNumOrg=YakujyoNum yakujyoChk=false doc.async = False '非同期をやめる。つまり同期にする。 url = BaseURL & "/ws/fx/yakujoList.do?" yfd=Year(Now) & Right("0" & Month(Now),2) & Right("0" & Day(Now), 2)'yfd="20081020" url=url & "yfd=" & yfd & "&ytd=" & yfd objIEx.document.all.url.value= url xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMOエラーyakujoList" + vbCrLf + "[" + msg + "]" & Now & "<br>" if msg="頻度を落としてリクエストしてください。" then wscript.sleep(5000) end if End If Set yakujoList = doc.documentElement.selectSingleNode("yakujoList").childNodes ii=0'shinkiChumonBango="10009818892" For Each ListItem In yakujoList Set ListItem = yakujoList.Item(ii) Num=ListItem.selectSingleNode("chumonBango").nodeTypedValue match=false for k= 0 to YakujyoNumOrg-1 if Num=YakujyoBango(k) then match=true exit for end if next if match=false then YakujyoBango(YakujyoNum)=Num YakujyoNum=YakujyoNum+1 end if nextend functionsub login(xml,doc,BaseURL,uid,passwd) doc.async = False '非同期をやめる。つまり同期にする。 'シーケンス１リダイレクト先を取得 xml.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせない 'GETメソッド版 'GETメソッドでも可能だったが、GMOの仕様書ではPOSTになっていた url = "https://sec-sso.click-sec.com/webservice/wsfx-redirect?u=" & uid '2008/03/29 URL変更 xml.Open "GET", url, False xml.send 'POSTの場合、一般的にこの指定が必要 Location = xml.getResponseHeader("Location") 'リダイレクト先URLの取得 aa = InStr(Len("https://") + 1, Location, "/") 'https://fx.click-sec.com/ の文字列数 bb = InStr(aa + 1, Location, "/") 'https://fx.click-sec.com/fx1-1/ の文字列数 '2008/03/29　基底URL取得方法修正 BaseURL = Left(xml.getResponseHeader("Location"), bb - 1) '基底URL = "https://fx.click-sec.com/fx1-1" xml.option(6) = True '6=WinHttpRequestOption_EnableRedirects '以後はリダイレクトをさせる 'シーケンス２リダイレクト先へ飛んでセッションIDを取得 url = Location xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End If 'シーケンス３ユーザ認証とリダイレクトでURLをたどっていく url = BaseURL & "/ws-login?j_username=" & uid & "&j_password=" & passwd xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then objIEx.Document.write "ユーザIDまたはパスワードが誤っています" WScript.Quit ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then '2007/04/03現在、GMOはこのエラーをかえさない。正常になる。ただし発注や一覧を問い合わせるとエラーになる objIEx.Document.write "GMOホームページに行って利用設定が必要です" WScript.Quit Else msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End If ElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End IfobjIEx.Document.write "Login完了<br>"end sub

2008.11.04

コメント(2)
FX投資クリック証券注文で取引数量など自動入力するシェルVBS,WSHでのIE操作例

このシェル起動で通貨ベア、取引数量、許容スリッページを入力する画面が現れますここに入力した値が、新規成行注文画面にプリセットされます実行中はいつでもこの値を変更できます・現在成行のみ、そのうち他もサポートします・通貨ベアUSD,EUR,GBRのみ、その他の通貨はソース中のselectタグに追加してくださいDim objIE0 Dim objIE1Dim sSet objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100Looprt=8objIEx.Width=600objIEx.Height=700objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "通貨ベア<SELECT name=tuuka> <OPTION selected value=0>USD/JPN</OPTION> <OPTION value=1>EUR/JPN</OPTION> <OPTION value=2>GBR/JPN</option></select>"objIEx.Document.Write "注文タイプ<SELECT name=type> <OPTION selected value =1>成行</OPTION> <OPTION value=2>通常</OPTION> <OPTION value=3>OCD</option><option value=4>IFD-OCO</option></select><br>"objIEx.Document.Write "取引数量<input type=input name=suu size=2 value=1>"objIEx.Document.Write "許容スリッページ<input type=input name=slip size=2 value=0><br>"objIEx.Document.Write "停止<input type=checkbox name=term><br>"'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseobjIEx.Document.Write "クリック証券のページ検索中<br>"do For Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://fx.click-sec.com/ygmo/servlet/ygmo.pc.gfr001.servlet.GFr00101?SID=web4" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end if next if win_s=true then exit do WScript.Sleep(1000)loopobjIEx.Document.Write "クリック証券のページあった、注文入力画面監視中<br>"WScript.Sleep(500)Set objFRAME = objIE0.Document.frames Set objIE1 = objFRAME("Main")do on error resume next do s=objIE1.document.body.outertext if err.Number=0 then exit do objIEx.Document.Write err.Description & " " & now & "<br>" WScript.Sleep(1000) Set objFRAME = objIE0.Document.frames Set objIE1 = objFRAME("Main") loop err.clear on error goto 0 if instr(s,"空欄時は制限なし")>0 then 'objIE1.document.all.tags("INPUT").item(8).Value = "yy" ' text objIE1.document.all.P002.value=objIEx.document.all.suu.value ' text index=14 objIE1.document.all.P005.value=objIEx.document.all.slip.value ' text index=15 objIE1.Document.all.P001.selectedIndex=objIEx.document.all.tuuka.selectedIndex+1 end if WScript.Sleep(1000) if objIEx.Document.all.term.checked=true then exit doloopobjIEx.Document.write "止めたよ"WScript.Quit

2008.10.24

コメント(1)
FX投資用為替レート取得読み上げシェル選択可能にしましたVBS,WSHでのIE操作例

ブラウザ(ie)の画面を表示しレート一覧、レートのBidまたはAskを5秒間隔で読み上げます前回の記事の変更版です。読み上げのレートをラジオボタンで選択できるようにしました。<A href="http://sky.geocities.jp/mujintrading/">こちらのサイト</a>からログイン、レート取得などキモ部分をまるまるコピーしました。ありがとうございます先頭2行をユーザid,パスワードの代入文に変更してくださいuid=""passwd=""Set objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100Looprt=8objIEx.Width=600objIEx.Height=700objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "<table>"objIEx.Document.Write "<tr><td>通貨ベア</td><td>Bid</td><td>Ask</td><td>前日終値比</td><td>Bid High</td><td>Bid Low</td><td>売Swap</td><td>買Swap</td></tr>"for i= 0 to 14 objIEx.Document.Write "<tr>" for j=0 to rt-1 objIEx.Document.Write "<td>" if j=1 or j=2 then objIEx.Document.Write "<input type=radio name=r>" '& cstr(i) & "_" & cstr(j) & ">" end if objIEx.Document.Write "<input size=3 type=input name=f" & cstr(i) & "_" & cstr(j) & "></td>" next objIEx.Document.Write "</tr>"nextobjIEx.Document.Write "</table>"objIEx.Document.Write "停止:<input type=checkbox name=term><br>"Set Voice1 = CreateObject("SAPI.SpVoice") Set xml = CreateObject("WinHttp.WinHttpRequest.5.1") Set doc = CreateObject("Microsoft.XMLDOM") 'メモ　CreateObjectするより、参照設定で指定したほうが本当はいいかも。 doc.async = False '非同期をやめる。つまり同期にする。 'シーケンス１リダイレクト先を取得 xml.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせない 'GETメソッド版 'GETメソッドでも可能だったが、GMOの仕様書ではPOSTになっていた url = "https://sec-sso.click-sec.com/webservice/wsfx-redirect?u=" & uid '2008/03/29 URL変更 xml.Open "GET", url, False xml.send 'POSTの場合、一般的にこの指定が必要 Location = xml.getResponseHeader("Location") 'リダイレクト先URLの取得 aa = InStr(Len("https://") + 1, Location, "/") 'https://fx.click-sec.com/ の文字列数 bb = InStr(aa + 1, Location, "/") 'https://fx.click-sec.com/fx1-1/ の文字列数 '2008/03/29　基底URL取得方法修正 BaseURL = Left(xml.getResponseHeader("Location"), bb - 1) '基底URL = "https://fx.click-sec.com/fx1-1" xml.option(6) = True '6=WinHttpRequestOption_EnableRedirects '以後はリダイレクトをさせる 'シーケンス２リダイレクト先へ飛んでセッションIDを取得 url = Location xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End If 'シーケンス３ユーザ認証とリダイレクトでURLをたどっていく url = BaseURL & "/ws-login?j_username=" & uid & "&j_password=" & passwd xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then objIEx.Document.write "ユーザIDまたはパスワードが誤っています" WScript.Quit ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then '2007/04/03現在、GMOはこのエラーをかえさない。正常になる。ただし発注や一覧を問い合わせるとエラーになる objIEx.Document.write "GMOホームページに行って利用設定が必要です" WScript.Quit Else msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End If ElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End IfobjIEx.Document.write "Login完了<br>" doc.async = False '非同期をやめる。つまり同期にする。 url = BaseURL & "/ws/fx/tsukaPairList.do" 'url="https://fx.gmo.jp/fx1-1/ws/fx/tsukaPairList.do" '引数なしなら、全通貨ペアを取得 'url="https://fx.gmo.jp/fx1-1/ws/fx/tsukaPairList.do&tka[0].tkt=1&tka[1].tkt=2" '引数指定も可能 xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" End If Set ListItems = doc.documentElement.selectSingleNode("tsukaPairList").childNodesii = 0Do While ii < ListItems.Length And ii < 15 Set ListItem = ListItems.Item(ii) ' = ListItem.Attributes.getNamedItem("tsukaPairCode").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+0).value= ListItem.Attributes.getNamedItem("tsukaPairName").nodeTypedValue ii = ii + 1Loopdo url = BaseURL & "/ws/fx/rateList.do" xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End If Set ListItems = doc.documentElement.selectSingleNode("rateList").childNodesii = 0 Do While ii < ListItems.Length And ii < 15 Set ListItem = ListItems.Item(ii) objIEx.document.all.tags("INPUT").item(ii*(rt+2)+2).value =ListItem.selectSingleNode("bid").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+4).value =ListItem.selectSingleNode("ask").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+5).value = ListItem.selectSingleNode("zenjitsuhi").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+6).value = ListItem.selectSingleNode("bidHigh").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+7).value = ListItem.selectSingleNode("bidLow").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+8).value = ListItem.selectSingleNode("uriSwap").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*(rt+2)+9).value = ListItem.selectSingleNode("kaiSwap").nodeTypedValue ii = ii + 1 Loopfor i= 0 to 14 for j=1 to 3 step 2 if objIEx.document.all.tags("INPUT").item(i*(rt+2)+j).checked=true then Set ListItem = ListItems.Item(i) if j=1 then Voice1.Speak ListItem.selectSingleNode("bid").nodeTypedValue else Voice1.Speak ListItem.selectSingleNode("ask").nodeTypedValue end if exit for end if nextnext If ii < ListItems.Length Then objIEx.Document.write "通貨ペアが15件以上あります" End If if objIEx.Document.all.term.checked=true then exit do WScript.Sleep (5000)loopdoc.async = False '非同期をやめる。つまり同期にする。url = BaseURL & "/ws-logout"xml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then objIEx.Document.write "logout error" else objIEx.Document.write "logout OK"End IfSet xml = NothingSet doc = Nothing

2008.10.21

コメント(0)
FX投資クリック証券レート取得読み上げシェル作ったよVBS,WSHでのIE操作例

ブラウザ(ie)の画面を表示しレート一覧、USD/JPNのBidを5秒間隔で読み上げます<A href="http://sky.geocities.jp/mujintrading/">こちらのサイト</a>からログイン、レート取得などキモ部分をまるまるコピーしました。ありがとうございます先頭2行をユーザid,パスワードの代入文に変更してくださいuid=""passwd=""Set objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100Looprt=8objIEx.Width=400objIEx.Height=400objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "<table>"objIEx.Document.Write "<tr><td>通貨ベア</td><td>Bid</td><td>Ask</td><td>前日終値比</td><td>Bid High</td><td>Bid Low</td><td>売Swap</td><td>買Swap</td></tr>"for i= 1 to 15 objIEx.Document.Write "<tr>" for j=1 to rt objIEx.Document.Write "<td><input size=3 type=input name=f" & cstr(i) & "_" & cstr(j) & "></td>" next objIEx.Document.Write "</tr>"nextobjIEx.Document.Write "</table>"objIEx.Document.Write "停止:<input type=checkbox name=term><br>"Set Voice1 = CreateObject("SAPI.SpVoice") Set xml = CreateObject("WinHttp.WinHttpRequest.5.1") Set doc = CreateObject("Microsoft.XMLDOM") 'メモ　CreateObjectするより、参照設定で指定したほうが本当はいいかも。 doc.async = False '非同期をやめる。つまり同期にする。 'シーケンス１リダイレクト先を取得 xml.option(6) = False '6=WinHttpRequestOption_EnableRedirects 'リダイレクトさせない 'GETメソッド版 'GETメソッドでも可能だったが、GMOの仕様書ではPOSTになっていた url = "https://sec-sso.click-sec.com/webservice/wsfx-redirect?u=" & uid '2008/03/29 URL変更 xml.Open "GET", url, False xml.send 'POSTメソッド版 'url = "https://sec-sso.gmo.jp/webservice/wsfx-redirect" 'url = "https://sec-sso.click-sec.com/webservice/wsfx-redirect" 'xml.Open "POST", url, False 'xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" 'POSTの場合、一般的にこの指定が必要 Location = xml.getResponseHeader("Location") 'リダイレクト先URLの取得 aa = InStr(Len("https://") + 1, Location, "/") 'https://fx.click-sec.com/ の文字列数 bb = InStr(aa + 1, Location, "/") 'https://fx.click-sec.com/fx1-1/ の文字列数 '2008/03/29　基底URL取得方法修正 BaseURL = Left(xml.getResponseHeader("Location"), bb - 1) '基底URL = "https://fx.click-sec.com/fx1-1" xml.option(6) = True '6=WinHttpRequestOption_EnableRedirects '以後はリダイレクトをさせる 'シーケンス２リダイレクト先へ飛んでセッションIDを取得 url = Location xml.Open "GET", url, False xml.send' Debug.Print xml.responseText doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" ' Exit Sub End If 'シーケンス３ユーザ認証とリダイレクトでURLをたどっていく url = BaseURL & "/ws-login?j_username=" & uid & "&j_password=" & passwd 'url=https://fx.click-sec.com/fx1-1/ws-login?j_username=999999999&j_password=111111 'Debug.Print url xml.Open "GET", url, False xml.send ' Debug.Print xml.responseText doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue = "NG" Then If doc.documentElement.selectSingleNode("message").nodeTypedValue = "Authentication Failure." Then MsgBox ("ユーザIDまたはパスワードが誤っています") 'Exit Sub ElseIf doc.documentElement.selectSingleNode("message").nodeTypedValue = "Web service is not permitted." Then '2007/04/03現在、GMOはこのエラーをかえさない。正常になる。ただし発注や一覧を問い合わせるとエラーになる MsgBox ("GMOホームページに行って利用設定が必要です") 'Exit Sub Else msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" 'Exit Sub End If ElseIf doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" 'Exit Sub End If objIEx.Document.write "Login完了<br>" doc.async = False '非同期をやめる。つまり同期にする。 url = BaseURL & "/ws/fx/tsukaPairList.do" 'url="https://fx.gmo.jp/fx1-1/ws/fx/tsukaPairList.do" '引数なしなら、全通貨ペアを取得 'url="https://fx.gmo.jp/fx1-1/ws/fx/tsukaPairList.do&tka[0].tkt=1&tka[1].tkt=2" '引数指定も可能 xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue MsgBox "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" End If 'Debug.Print xml.responseText Set ListItems = doc.documentElement.selectSingleNode("tsukaPairList").childNodesii = 0Do While ii < ListItems.Length And ii < 15 Set ListItem = ListItems.Item(ii) ' = ListItem.Attributes.getNamedItem("tsukaPairCode").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*rt+0).value= ListItem.Attributes.getNamedItem("tsukaPairName").nodeTypedValue ' = ListItem.selectSingleNode("maxTorihikiSuryo").nodeTypedValue '= ListItem.selectSingleNode("minTorihikiSuryo").nodeTypedValue ' = ListItem.selectSingleNode("torihikiTani").nodeTypedValue ' = ListItem.selectSingleNode("yobineTani").nodeTypedValue '2008/09/25 FX-V1.1.0版よりyobineTaniが追加 ii = ii + 1Loopdo url = BaseURL & "/ws/fx/rateList.do" xml.Open "GET", url, False xml.send doc.loadXML (xml.responseText) If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then msg = doc.documentElement.selectSingleNode("message").nodeTypedValue objIEx.Document.write "GMO側が以下のエラーを返しました" + vbCrLf + "[" + msg + "]" WScript.Quit End If Set ListItems = doc.documentElement.selectSingleNode("rateList").childNodesii = 0 Do While ii < ListItems.Length And ii < 15 Set ListItem = ListItems.Item(ii) objIEx.document.all.tags("INPUT").item(ii*rt+1).value =ListItem.selectSingleNode("bid").nodeTypedValueif ii=0 then Voice1.Speak ListItem.selectSingleNode("bid").nodeTypedValueend if objIEx.document.all.tags("INPUT").item(ii*rt+2).value =ListItem.selectSingleNode("ask").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*rt+3).value = ListItem.selectSingleNode("zenjitsuhi").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*rt+4).value = ListItem.selectSingleNode("bidHigh").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*rt+5).value = ListItem.selectSingleNode("bidLow").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*rt+6).value = ListItem.selectSingleNode("uriSwap").nodeTypedValue objIEx.document.all.tags("INPUT").item(ii*rt+7).value = ListItem.selectSingleNode("kaiSwap").nodeTypedValue ' = ListItem.selectSingleNode("hasseibi").nodeTypedValue ' = ListItem.selectSingleNode("fuyoNissu").nodeTypedValue ' = ListItem.selectSingleNode("nichiji").nodeTypedValue '2008/09/25 FX-V1.1.0版よりnichijiが追加 ii = ii + 1 Loop If ii < ListItems.Length Then objIEx.Document.write "通貨ペアが15件以上あります" End If if objIEx.Document.all.term.checked=true then exit do WScript.Sleep (5000)loopdoc.async = False '非同期をやめる。つまり同期にする。url = BaseURL & "/ws-logout"xml.Open "GET", url, Falsexml.senddoc.loadXML (xml.responseText)If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then objIEx.Document.write "logout error" else objIEx.Document.write "logout OK"End IfSet xml = NothingSet doc = Nothing'Err: 'MsgBox "エラーが発生しました" + vbCrLf + Err.Description, vbOKOnly

2008.10.21

コメント(0)
FX投資株式手数料105円～クリック証券総合口座のログインシェル作ったよVBS,WSHでのIE操作例

以下ソースです、最後から7･8行目にパスワード、ログインidの代入文に変更してくださいDim objIE0'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.document) = "HTMLDocument" Then If Window.document.URL = "https://sec-sso.click-sec.com/loginweb/" Then Set objIE0 = Window '対象URLが表示→その画面を使う win_s = True Exit For End If End IfNextIf win_s = False Then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://sec-sso.click-sec.com/loginweb/" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" LoopEnd If'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.j_username.Value = "" ' text index=0objIE0.document.all.j_password.Value = "" ' password index=1For Each objTAG In objIE0.document.getElementsByTagName("BUTTON") If objTAG.Type = "submit" Then objTAG.Click Exit For End IfNext

2008.10.15

コメント(0)
FX投資外為どっとコム外貨ネクスト総合口座のログインシェル作ったよVBS,WSHでのIE操作例

以下ソースです、最後から3･4行目にパスワード、ログインidの代入文に変更してくださいDim objIE0Dim s'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://trade.gaitame.com/members/" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://trade.gaitame.com/members/" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.userid.value="" ' text index=2objIE0.document.all.password.value="" ' password index=3'objIE0.document.all.trade.click ' checkbox 携帯電話・モバイル端末は、こちらからご利用ください。objIE0.document.all.Submit.click ' submit Submit ログイン or tags("INPUT").item(5).Click

2008.09.27

コメント(1)
FX投資外為どっとコムのログインシェル作ったよVBS,WSHでのIE操作例

以下ソースです、最後から2･3行目にパスワード、ログインidの代入文に変更してくださいDim s'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://fx.gaitame.com/members/" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://fx.gaitame.com/members/" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.userid.value="" ' text index=2objIE0.document.all.password.value="" ' password index=3objIE0.document.all.Submit.click ' submit Submit ログイン or tags("INPUT").item(4).Click

2008.09.26

コメント(0)
FX投資くりっく365のログインシェル作ったよVBS,WSHでのIE操作例

以下ソースです、最後から2･3行目にパスワード、ログインidの代入文に変更してくださいDim objIE0Dim s'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://trade.starkawase.jp/fxcwebpresen-tfx/Login.do" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://trade.starkawase.jp/fxcwebpresen-tfx/Login.do" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.loginId.value="" ' text index=1objIE0.document.all.password.value="" ' password index=2objIE0.Document.links(0).click 'ログイン

2008.09.25

コメント(0)
FX投資Spot Boardのログインシェル作ったよ楽天ポイント10000キャンペーン中だって

以下ソースです、最後から2･3行目にパスワード、ログインidの代入文に変更してくださいDim objIE0Dim s '対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="http://spotboard.mj-net.jp/" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "http://spotboard.mj-net.jp/" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.loginId.value="" ' text index=0objIE0.document.all.password.value="" ' password index=1objIE0.Document.links(0).click

2008.09.24

コメント(2)
FX投資Spot Boardのログインシェル作ったよ楽天ポイント10000キャンペーン中だって

以下ソースです、最後から2･3行目にパスワード、ログインidの代入文に変更してくださいDim objIE0Dim s '対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="http://spotboard.mj-net.jp/" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "http://spotboard.mj-net.jp/" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend if'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.document.all.loginId.value="" ' text index=0objIE0.document.all.password.value="" ' password index=1objIE0.Document.links(0).click

2008.09.24

コメント(0)
Google MapをEXCELのセルの値で表示するマクロ

使い方：EXCELの任意のセルに住所を入力、”東京都新宿区歌舞伎町”てな感じで　　　　　そのセルに位置づけマクロを実行動作：セルの住所からgoogleの地図を表示します以下マクロのソースですDim objIE0 As Object 'ルートのオブジェクト、操作コードではこの名称を使用しますDim objIE1 As Object, objIE2 As Object 'FRAMEのオブジェクト、ネストが3重以上になる場合は、objIE3,objIE4・・・を追加してくださいDim s As String'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then If Window.Document.url = "http://maps.google.co.jp/maps?hl=ja&tab=wl" Then Set objIE0 = Window '対象URLが表示→その画面を使う win_s = True Exit For End If End IfNextIf win_s = False Then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "http://maps.google.co.jp/maps?hl=ja&tab=wl" Do While objIE0.busy = True DoEvents Loop Do While objIE0.Document.readyState "complete" DoEvents LoopEnd IfobjIE0.Document.all.tags("INPUT").Item(5).Value = ActiveCell.Value ' text index=5objIE0.Document.all.tags("INPUT").Item(6).Click ' submit btnG 地図を検索 or tags("INPUT").item(6)

2008.08.07

コメント(8)
AmazonにDVD出品してみる

ページのhtmlの内容が物によって異なるタイトルのがあるとかないとかそんな事情で長らく出品していなかったが現在の出品一覧です

2008.08.06

コメント(1)
フォルダ内のファイル名一覧をクリップボードにコピーするVBS

動機：CDから取り込んだ音楽の名前を一覧にしたいので、こんなもの作ってみた拡張子.wmaの一覧をクリップボードにコピーする例ですソースは次folderpath = "./"Set objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy Or objIEx.ReadyState4 Wscript.Sleep 10Loops=""set fs = CreateObject("Scripting.FileSystemObject")'Set oTs1 = fs.OpenTextFile("ichiran.txt",2,true) set folder = fs.GetFolder(folderpath) for each a in folder.Files if right(a.name,4)=".wma" then 'oTs1.WriteLine left(a.name,len(a.name)-4) s=s & left(a.name,len(a.name)-4) & vbcrlf end if NextobjIEx.Document.parentWindow.clipboardData.setData "text",sset objIEx=nothing'oTs1.close

2008.07.23

コメント(0)
Biglobeログイン自動入力するシェル(vbs,WSH)

下記のソース中の2箇所を修正してください・ユーザidの代入文・パスワードの代入文以下ソースですSet objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100LoopobjIEx.Width=300 objIEx.Height=500objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "状態:<input name=stat value=""不明""><br>"objIEx.Document.Write "終了:<input type=checkbox name=term><br>"on error resume nextSet xShell = CreateObject("Shell.Application")do win=false if objIEx.Document.all.term.checked=true then exit do wscript.sleep(1000) For Each Window In xShell.Windows '対象URLが表示されているか？ if err.number <>0 then objIEx.Document.Write "err xShell.Windows " & err.description & "num=" & err.number & "<br>" exit for end if If TypeName(Window.Document) = "HTMLDocument" Then if err.number <>0 then objIEx.Document.Write "err TypeName " & err.description & "num=" & err.number & "<br>" exit for end if if instr(Window.Document.url,"https://my.sso.biglobe.ne.jp/index.html")>0 then win=true Set objIE0 = Window '対象URLが表示→その画面を使う if instr(objIE0.document.body.innerhtml,"btn_login.gif")>0 then objIE0.document.all.loginname.value="" ' ユーザidの代入文 objIE0.document.all.userpass.value="" ' パスワードの代入文 objIE0.document.all.tags("INPUT").item(4).Click ' objIEx.Document.Write "Login button press " & time & "<br>" Do While objIE0.busy = True Loop Do While objIE0.document.readyState <> "complete" Loop objIEx.Document.Write "Login success " & time & "<br>" objIEx.Document.all.stat.value="ログイン成功" exit for else objIEx.Document.all.stat.value="ログイン中" end if end if end if next if win=false then objIEx.Document.all.stat.value="Biglobeログイン画面なし" end if err.clearloopobjIEx.Document.Write "止めたよ"

2008.07.17

コメント(3)
Yahooオークション取引ナビのメッセージを自動表示するVBS

”Yahoo!オークション取引連絡”メールをキーにメッセージのみIEの画面に表示するシェルです前提：メーラーOUTLOOK,”取引連絡”の名前のフォルダに”Yahoo!オークション取引連絡”メールがあることソースは以下Set objIE = CreateObject("InternetExplorer.application")objIE.Visible = falseSet objIEs = CreateObject("InternetExplorer.application")objIEs.Visible = True Set olAPP = CreateObject("Outlook.Application") Set olNameSPC = olAPP.GetNamespace("MAPI") ' Namespace オブジェクト mail_folder_row = 1 mail_folder = "取引連絡" For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count sss = olNameSPC.Folders(1).Folders(nFCNT).name If olNameSPC.Folders(1).Folders(nFCNT).name = mail_folder Then Exit For Next If nFCNT > olNameSPC.Folders(1).Folders.Count Then MsgBox (mail_folder & "はありません") End If 'mail_num = olNameSPC.Folders(1).Folders(nFCNT).Count hit = 0 nf = 0 For Each objItem In olNameSPC.Folders(1).Folders(nFCNT).Items With objItem strSubject = .Subject End With id = strmid(strSubject, "(", ")") url = "http://page.auctions.yahoo.co.jp/jp/show/contact?aID=" & id & "#message" key="" for bb= len(strSubject) to 1 step -1 if mid(strSubject,bb,1)=" " then exit for key=mid(strSubject,bb,1) & key next msg = torihiki_navi_get_f(objIE, objIEs, url,key) objItem.FlagStatus = 2 'olFlagMarked (2)をセット参照設定時は定数で objItem.FlagRequest = "読んだよ " & Now 'フラグ内容をセット 'objItem.FlagDueBy = Now '今回は期限はセットしない objItem.Save Nextset objIE=nothingFunction torihiki_navi_get_f(objIE,objIEs,url,key)'Dim s As String, msg As String'url = Replace(url, "/auction/", "/show/contact?aID=") & "#message"'http://page5.auctions.yahoo.co.jp/jp/auction/e70050275'"http://page5.auctions.yahoo.co.jp/jp/show/contact?aID=e70050275#message"objIE.Navigate urlCall ie_wait(objIE)msg = ""j = 0For i = objIE.Document.links.Length - 6 To 0 Step -1 If InStr(objIE.Document.links(i).outertext, "連絡掲示板") > 0 Then Exit For' If objIE.Document.links(i).outertext = "送付先住所、支払い、発送などについて" Or _' objIE.Document.links(i).outertext = "その他" Or _' objIE.Document.links(i).outertext = "支払いが完了しました" Or _' objIE.Document.links(i).outertext = "商品を受け取りました" _ If objIE.Document.links(i).outertext = key Then objIEs.Navigate objIE.Document.links(i).href Call ie_wait(objIEs) s = objIEs.Document.body.innerhtml s = strmid(s, "WORD-BREAK", "") s = strmid(s, "", "") s = Replace(s, "", vbCrLf) msg = msg & s & vbCrLf & "***以上msg" & CStr(j) & "***" j = j + 1 'Exit For End IfNextmsg = Replace(msg, " ", "")msg = Replace(msg, "　", "")s = ""mae = ""For i = 1 To Len(msg) If Mid(msg, i, 1) vbCr And Mid(msg, i, 1) vbCr Then If mae "" Then s = s & mae s = s & Mid(msg, i, 1) s = "" Else If mae = Mid(msg, i, 1) Then Else s = s & Mid(msg, i, 1) End If End IfNexttorihiki_navi_get_f = msgEnd FunctionFunction 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 IfEnd FunctionSub ie_wait (objIE) Do While objIE.busy Loop Do While objIE.Document.readyState "complete" LoopEnd Sub

2008.07.16

コメント(4)
迷惑メールのタイトル、2日で約90件こんな感じです

禁止キーワードがあるとのことで、こちらのサイトにアップしました1つ前のブログ”迷惑メールを自動仕訳”のMeiwakuKW.txtにしてください

2008.07.12

コメント(1)
迷惑メールを自動仕訳 outlook wsh vbs

前提：MeiwakuKW.txtのファイル名で迷惑メールと判断するキーワードが１行１件記述すること動作：受信トレイのタイトルとMeiwakuKW.txt中の迷惑キーワードをつき合わせ、含まれるものを"迷惑"のフォルダーに移動する以下スクリプトのソースですDim objMail, objApp, objArgsdim kw(9999)Set objApp = CreateObject("Outlook.Application")Set olNameSPC = objApp.GetNamespace("MAPI")dest = "迷惑"mail_folder = "受信トレイ"Set Fs = WScript.CreateObject("Scripting.FileSystemObject")Set oTs1 = Fs.OpenTextFile("MeiwakuKW.txt",1) kc=0Do Until oTs1.AtEndOfStream 'oTs1を末端まで読み込むまでループを繰り返す s = oTs1.ReadLine kw(kc)=s kc=kc+1loopoTs1.Closemcnt=0ac=0mc=0For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count If olNameSPC.Folders(1).Folders(nFCNT).name = mail_folder Then Exit ForNextIf nFCNT > olNameSPC.Folders(1).Folders.Count Then MsgBox (mail_folder & "はありません")else For Each objItem In olNameSPC.Folders(1).Folders(nFCNT).Items mcnt=mcnt+1 With objItem 'dteCreateDate = .CreationTime strSubject = .Subject 'strAddress = .To 'strItemType = TypeName(objItem) 'strBody = .body End With hit=false for i=0 to kc-1 if instr(kw(i),strSubject)>0 then mc=mc+1 objItem.Move olNameSPC.Folders(1).Folders(dest) exit for end if next nextEnd IfSet oTs1 = Fs.OpenTextFile("MeiwakuKW.txt",2,true)for i=0 to kc-1 oTs1.writeline kw(i)nextoTs1.Closemsgbox "total=" & mcnt & " move=" & mcSet olNameSPC = NothingSet objApp = Nothing

2008.07.12

コメント(0)
開きすぎて閉じるのが面倒になったIEの画面をURLをキーにして一括消去するシェル

開きすぎて閉じるのが面倒になったIEの画面をURLをキーにして一括消去するシェルですWSH(VBS)ですこちらに説明・ソースがあります■このスクリプトで学べることIE操作：CreateObject("InternetExplorer.application")　Navigate　Visible文字列操作：InStr　Right　Left構文：For Each Next IF THEN ELSE 関数：MsgBox　Sleepその他多々

2008.07.11

コメント(0)
フォルダ内のファイル名一覧をクリップボードにコピーするVBS

動機：CDから取り込んだ音楽の名前を一覧にしたいので、こんなもの作ってみた拡張子.wmaの一覧をクリップボードにコピーする例ですソースは次folderpath = "./"Set objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy Or objIEx.ReadyState4 Wscript.Sleep 10Loops=""set fs = CreateObject("Scripting.FileSystemObject")'Set oTs1 = fs.OpenTextFile("ichiran.txt",2,true) set folder = fs.GetFolder(folderpath) for each a in folder.Files if right(a.name,4)=".wma" then 'oTs1.WriteLine left(a.name,len(a.name)-4) s=s & left(a.name,len(a.name)-4) & vbcrlf end if NextobjIEx.Document.parentWindow.clipboardData.setData "text",sset objIEx=nothing'oTs1.close

2008.07.06

コメント(1)
Pasmoマイページログイン・残額履歴を取り込むEXCELブック作ったよ

Pasmoマイページに自動ログイン（ユーザidなどの入力自動化）ＳＦ残額履歴をEXCELに取り込みますこちらからダウンロードしてください

2008.07.04

コメント(0)
楽天ブログ・トラックバック一括削除WSH活用例

一括削除のボタンはあるのだが、こいつが効かない個別削除を繰り返すvbsを作りましたxxx.vbsの名前でファイルを作りソースをテキストエディタなどで以下をコピーそのファイルのダブルクリックで一括削除できますトラックバック一覧が複数ページになる場合は想定していませんそのうち複数もできるようにしますソースは以下Dim objIE0Dim objIE1Dim s'対象画面を検索、なければ開く（必要に応じ使用してください）Set xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://my.plaza.rakuten.co.jp/index.phtml?func=diary&act=trackback" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://my.plaza.rakuten.co.jp/index.phtml?func=diary&act=trackback" Do While objIE0.busy = True Loop Do While objIE0.document.readyState "complete" Loopend ifSet objIEdel = CreateObject("InternetExplorer.Application")objIEdel.Visible = Truefor ii=0 to objIE0.document.links.Length - 1 if instr(objIE0.document.links(ii).href,"sub_act=delete")>0 then objIEdel.Navigate objIE0.document.links(ii).href Do While objIEdel.busy = True Loop Do While objIEdel.document.readyState "complete" Loop objIEdel.document.all.tags("INPUT").item(0).Click Do While objIEdel.busy = True Loop Do While objIEdel.document.readyState "complete" Loop end ifnext'For Each objTAG In objIE0.document.getElementsByTagName("INPUT")' if instr(objTAG.name,"del_list") then' objTAG.click' end if'next'objIE0.document.all.tags("INPUT").item(25).Click

2008.07.02

コメント(0)
NTT@ビリング自動ログイン・シェル作ったよ電話料金紹介 vbs,wsh

下記ソースのuserId、password、お客様番号の3箇所をご自分のものの代入文に変更してください何とか.vbsの名称で保存、ダブルクリックで実行できます以下ソースですSet xShell = CreateObject("Shell.Application")win_s = FalseFor Each Window In xShell.Windows '対象URLが表示されているか？ If TypeName(Window.Document) = "HTMLDocument" Then if Window.Document.url="https://www.billing.ntt-east.co.jp/entrance" then Set objIE0 = Window '対象URLが表示→その画面を使う win_s=true exit for end if end ifnextif win_s=false then '対象URLが非表示→新しく画面を開く Set objIE0 = CreateObject("InternetExplorer.Application") objIE0.Visible = True objIE0.Navigate "https://www.billing.ntt-east.co.jp/entrance" call waitPage(objIE0)end ifobjIE0.document.all.userID.value="" ' userId index=0objIE0.document.all.password.value="" ' password index=1objIE0.document.all.okyakusamaDenban.value="" ' お客様番号 index=2objIE0.document.all.LoginAction.clickSub waitPage (objIE) Do While objIE.busy Loop Do While objIE.Document.readyState "complete" LoopEnd Sub

2008.07.01

コメント(0)
迷惑メールアドレスをYahooメールに自動登録 wsh,vbs,outlook

前提：outlookに迷惑のフォルダがあり、そこに登録するメールを置く以下、vbsのソースですDim objMail, objApp, objArgsSet objApp = CreateObject("Outlook.Application")Set olNameSPC = objApp.GetNamespace("MAPI")mail_folder = "迷惑"Set objIE = CreateObject("InternetExplorer.application")objIE.Visible = trueobjIE.navigate "http://www.yahoo.co.jp/"call waitPage(objIE)rc=link_click(objIE,"text","メール")rc=-1'do until rc=0 rc=link_click(objIE,"text","メールオプション ")' wscript.sleep(100)'loop'do until rc=0 rc=link_click(objIE,"text","受信拒否")' wscript.sleep(100)'loop'objIE.navigate "http://jp.f40.mail.yahoo.co.jp/ym/BlockSender?YY=78517"'call waitPage(objIE)Set Fs = WScript.CreateObject("Scripting.FileSystemObject")mcnt=0For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count If olNameSPC.Folders(1).Folders(nFCNT).name = mail_folder Then Exit ForNextIf nFCNT > olNameSPC.Folders(1).Folders.Count Then MsgBox (mail_folder & "はありません")else For Each objItem In olNameSPC.Folders(1).Folders(nFCNT).Items mcnt=mcnt+1 fName = fs.GetAbsolutePathName(".") & "\mail_save.txt" objItem.SaveAs fName, olTXT m_hit = False Set oTs1 = Fs.OpenTextFile(fName,1) 'Do Until oTs1.AtEndOfStream 'oTs1を末端まで読み込むまでループを繰り返す s = oTs1.ReadLine 'loop adrs="" for i=len(s) to 1 step -1 adrs=mid(s,i,1) & adrs if mid(s,i,1)="[" then exit for end if next if instr(adrs,"]")>0 then adrs=strmid(adrs,"[","]") end if if instr(adrs," ")>0 then adrs=right(adrs,len(adrs)-instr(adrs," ")) end if' msgbox adrs oTs1.Close objIE.document.all.NE.value=adrs objIE.document.all.addblock.Click call waitPage(objIE) if instr(objIE.document.body.outertext,"このアドレスはすでに受信拒否登録されています。")>0 then registerd=registerd+1 end if nextEnd Ifmsgbox "total=" & mcnt & " registerd=" & registerdSet olNameSPC = NothingSet objApp = NothingFunction 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 IfEnd FunctionFunction waitPage (objIE) Do While objIE.busy Loop Do While objIE.Document.readyState "complete" Loop'if MsgBox("nuke " & Timer & " " & s_t, VbOKCancel, "WS") = vbOK Then WScript.QuitEnd function Function link_click(objIE, typ, v)link_click = -1if typ="num" then objIE.document.links(v).Click Call ie_wait(objIE) link_click = 0else For i = 0 To objIE.document.links.Length - 1 If typ = "text" Then If objIE.document.links(i).outertext = v Then objIE.document.links(i).Click Call waitPage(objIE) link_click = 0 Exit For End If End If If typ = "href" Then If objIE.document.links(i).href = v Then objIE.document.links(i).Click Call waitPage(objIE) link_click = 0 Exit For End If End If If typ = "href_inc" Then If InStr(objIE.document.links(i).href, v) > 0 Then objIE.document.links(i).Click Call waitPage(objIE) link_click = 0 Exit For End If End If Nextend ifEnd Function

2008.06.30

コメント(0)
アイドル・露出型女優・タレントDVD・写真集中古相場作ったよ

アイドル・露出型女優・タレント　DVD・写真集一覧、格安品の購入、せどりの価格調査などにご活用ください

2008.06.30

コメント(0)
みずほ銀行(旧富士)ログイン、振込みの第2暗証番号入力を自動化するシェル作ったよ

WSH(VBS)です。アイコンのダブルクリックでログイン・第2暗証番号の入力が自動化できますこちらに説明・ソースがあります

2008.06.25

コメント(0)
biglobeブログ記事投稿のvba作ったよEXCEL

EXCELでB列にタイトル、C列に本文を入れるその行のどれかのセルを選択次のマクロを実行Sub biglobe_blog()Dim objIE0 As Object 'ルートのオブジェクト、操作コードではこの名称を使用しますDim objIE1 As Object, objIE2 As Object 'FRAMEのオブジェクト、ネストが3重以上になる場合は、objIE3,objIE4・・・を追加してくださいDim s As StringSet objIE0 = CreateObject("InternetExplorer.Application")objIE0.Visible = TrueobjIE0.Navigate "https://bblog.sso.biglobe.ne.jp/ap/tool/newnewseditdisplay.do"Call ie_wait(objIE0)c_row = ActiveCell.Row'---header end---'---以下操作コード、必要な部分をコピーしてください---objIE0.Document.all.textbody.Value = Cells(c_row, 3).Value ' textareaobjIE0.Document.all.Title.Value = Cells(c_row, 2).Value ' text index=1'objIE0.Document.all.img_alignment(0).Checked = True ' radio 左'objIE0.Document.all.img_alignment(1).Checked = True ' radio 中央'objIE0.Document.all.img_alignment(2).Checked = True ' radio 右objIE0.Document.all.tags("INPUT").Item(5).Click 'button 次へ'objIE0.Document.all.tags("INPUT").Item(6).Click 'button ケータイ投稿設定Call ie_wait(objIE0)Call input_v_set(objIE0, "click_src", "公開", "")End Sub

2008.06.22

コメント(1)

全54件 (54件中 1-50件目)

1 2 >

ジャンル別一覧

出産・子育て
ファッション
美容・コスメ
健康・ダイエット
生活・インテリア
料理・食べ物
ドリンク・お酒

ペット
趣味・ゲーム
映画・ＴＶ
音楽
読書・コミック
旅行・海外情報
園芸

スポーツ
アウトドア・釣り
車・バイク
パソコン・家電
そのほか
すべてのジャンル

人気のクチコミテーマ

いいもの見つけたよ

15％OFFｸｰﾎﾟﾝ＋Ｐ5倍！QCY Crossky C…

(2024-11-07 21:50:57)
楽天ブログいろいろ

ブログの編集｜日付変更｜記事にいく…

(2024-11-06 14:53:45)
iPhone

iPhone12　PROのバッテリーがそろそ…

(2024-11-06 21:08:34)

EXCEL VBA TIPS

北沢署警部補･掛本六男駐車違反住民にインネン

FXキングmyページ・ログインシェル作ったよVBS,WSHでのIE操作例

郵貯オンライン画面変わったexcel入金取り込み訂正

怠慢警官・村上 川崎市多摩警察署 駐車違反取り締まらず

怠慢警官・村上 川崎市多摩警察署 駐車違反取り締まらず

クレジットカードの買い物一覧をEXCELに取り込むVBA famima Tカード

クリック証券API終了とりあえず取引暗証番号を自動入力するシェルで対応wsh,vbs

みんなのFXログインシェル作ったよVBS,WSHでのIE操作例

クレジットカード未請求買い物一覧をEXCELに取り込むVBA OMCカード

新生銀行セキュリティ番号猶予期間終わってしまった→だいたい自動化できた

イーバンク・ログイン生年月日自動入力

FXマネーパートナーズのログインシェル作ったよVBS,WSHでのIE操作例

クレジットカードの買い物一覧をEXCELに取り込むVBA OMCカード

金沢/富山～東京帰省終電遅れで新幹線接続不可、ホテル宿泊に

クリック証券の取引暗証番号を自動入力するシェルwsh,vbs

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

ヤマトメール便使ってますか？お役立ちシェル紹介します

Yahoo APIでオークション出品一覧取り込みVBA XML

かざか証券QUICK情報よりリアルタイム値を取得する関数VBS,WSH,IE操作

クリック証券の株式売買を自前の画面で、カスタマイズみたいシェルVBS,WSHでのIE操作例

クリック証券保有株信用建玉一覧表示シェルVBS,WSHでのIE操作例

クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました

クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました

クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました

FX投資クリック証券約定読み上げシェルVBS,WSHでのIE操作例

FX投資クリック証券注文で取引数量など自動入力するシェルVBS,WSHでのIE操作例

FX投資用為替レート取得読み上げシェル選択可能にしましたVBS,WSHでのIE操作例

FX投資クリック証券レート取得読み上げシェル作ったよVBS,WSHでのIE操作例

FX投資株式手数料105円～クリック証券総合口座のログインシェル作ったよVBS,WSHでのIE操作例

FX投資外為どっとコム外貨ネクスト総合口座のログインシェル作ったよVBS,WSHでのIE操作例

FX投資外為どっとコムのログインシェル作ったよVBS,WSHでのIE操作例

FX投資くりっく365のログインシェル作ったよVBS,WSHでのIE操作例

FX投資Spot Boardのログインシェル作ったよ楽天ポイント10000キャンペーン中だって

FX投資Spot Boardのログインシェル作ったよ楽天ポイント10000キャンペーン中だって

Google MapをEXCELのセルの値で表示するマクロ

AmazonにDVD出品してみる

フォルダ内のファイル名一覧をクリップボードにコピーするVBS

Biglobeログイン自動入力するシェル(vbs,WSH)

Yahooオークション取引ナビのメッセージを自動表示するVBS

迷惑メールのタイトル、2日で約90件こんな感じです

迷惑メールを自動仕訳 outlook wsh vbs

開きすぎて閉じるのが面倒になったIEの画面をURLをキーにして一括消去するシェル

フォルダ内のファイル名一覧をクリップボードにコピーするVBS

Pasmoマイページログイン・残額履歴を取り込むEXCELブック作ったよ

楽天ブログ・トラックバック一括削除WSH活用例

NTT@ビリング自動ログイン・シェル作ったよ 電話料金紹介 vbs,wsh

迷惑メールアドレスをYahooメールに自動登録 wsh,vbs,outlook

アイドル・露出型女優・タレントDVD・写真集中古相場作ったよ

みずほ銀行(旧富士)ログイン、振込みの第2暗証番号入力を自動化するシェル作ったよ

biglobeブログ記事投稿のvba作ったよEXCEL

怠慢警官・村上川崎市多摩警察署駐車違反取り締まらず

怠慢警官・村上川崎市多摩警察署駐車違反取り締まらず

NTT@ビリング自動ログイン・シェル作ったよ電話料金紹介 vbs,wsh