PR
キーワードサーチ
▼キーワード検索
EXCEL VBA TIPS
わたしのブログへようこそ
カレンダー
コメント新着
フリーページ
2008.11.07
カテゴリ： カテゴリ未分類
クリック証券のWebサービスで株式の約定一覧をexcelに取り込むマクロを作りました
こちらのサイト からログイン、約定一覧取得などキモ部分をまるまるコピーしました。ありがとうございます
＜前提＞
accountの名前のシートにユーザid,パスワードを置くこと
Cells(2, 10).Value ユーザid
Cells(3, 10).Value パスワード
＜取り込み仕様＞
1列:受渡日
2列:銘柄コード
4列:約定数量
5列:約定単価
6列:受渡額
7列:手数料
10列:受付番号
＜困った事、返答してくれない項目がある＞
1)手数料、信用の諸経費
現物は受け渡し額・単価・数で計算できるが、信用は対応する新規約定と突き合せないとわからない→私の場合約定毎なので150円固定値にした。1日定額の方は、150円を0円に変更していただき、取り込み後に任意の行に手数料をセットしてください。1つのセルだけの操作でいけるはずです
諸経費はどうでもいいや。決済の額で損得計算できるから。そういう意味では手数料もどうでもいい
2)銘柄名
手で入力してください。ex:アイオーデータ[6916]の”アイオーデータ”は手で入力
以下ソースです
uid = Worksheets("account").Cells(2, 10).Value
passwd = Worksheets("account").Cells(3, 10).Value
On Error GoTo Err:
With ActiveWorkbook.Worksheets(ActiveWorkbook.ActiveSheet.Name)
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 If
Application.StatusBar = "Login完了"
set_pos = 2
uri_torikomi = 0
kai_torikomi = 0
uri_c = 0
kai_c = 0
sin_uri_torikomi = 0
sin_kai_torikomi = 0
sin_uri_c = 0
sin_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 If
Set ListItems = doc.documentElement.selectSingleNode("yakujoList").childNodes
YakuNum = ListItems.Length
YakuNum_Sumi = YakuNum
For ii = 0 To YakuNum - 1
Set 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_name
If ListItem.selectSingleNode("baibai").nodeTypedValue = "2" Then
syubetu = "買"
Else
syubetu = "売"
End If
If ListItem.selectSingleNode("torihiki").nodeTypedValue = "22" Then
syubetu = "返済" & syubetu
End If
If ListItem.selectSingleNode("torihiki").nodeTypedValue = "21" Then
syubetu = "信用" & syubetu
End If
If ListItem.selectSingleNode("torihiki").nodeTypedValue = "23" Then
If syubetu = "買" Then
syubetu = "現引"
Else
syubetu = "現渡"
End If
End If
If InStr(syubetu, "現渡") > 0 Or InStr(syubetu, "現引") > 0 Then
Else
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 If
End 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_torikomi
doc.async = False
URL = 基底URL & "/ws-logout"
XML.Open "GET", URL, False
XML.send
doc.loadXML (XML.responseText)
If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then
GoTo Err:
End If
Set XML = Nothing
Set doc = Nothing
Exit Sub
Err:
Application.StatusBar = "エラーが発生しました" + vbCrLf + Err.Description
こちらのサイト からログイン、約定一覧取得などキモ部分をまるまるコピーしました。ありがとうございます
＜前提＞
accountの名前のシートにユーザid,パスワードを置くこと
Cells(2, 10).Value ユーザid
Cells(3, 10).Value パスワード
＜取り込み仕様＞
1列:受渡日
2列:銘柄コード
4列:約定数量
5列:約定単価
6列:受渡額
7列:手数料
10列:受付番号
＜困った事、返答してくれない項目がある＞
1)手数料、信用の諸経費
現物は受け渡し額・単価・数で計算できるが、信用は対応する新規約定と突き合せないとわからない→私の場合約定毎なので150円固定値にした。1日定額の方は、150円を0円に変更していただき、取り込み後に任意の行に手数料をセットしてください。1つのセルだけの操作でいけるはずです
諸経費はどうでもいいや。決済の額で損得計算できるから。そういう意味では手数料もどうでもいい
2)銘柄名
手で入力してください。ex:アイオーデータ[6916]の”アイオーデータ”は手で入力
以下ソースです
uid = Worksheets("account").Cells(2, 10).Value
passwd = Worksheets("account").Cells(3, 10).Value
On Error GoTo Err:
With ActiveWorkbook.Worksheets(ActiveWorkbook.ActiveSheet.Name)
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 If
Application.StatusBar = "Login完了"
set_pos = 2
uri_torikomi = 0
kai_torikomi = 0
uri_c = 0
kai_c = 0
sin_uri_torikomi = 0
sin_kai_torikomi = 0
sin_uri_c = 0
sin_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 If
Set ListItems = doc.documentElement.selectSingleNode("yakujoList").childNodes
YakuNum = ListItems.Length
YakuNum_Sumi = YakuNum
For ii = 0 To YakuNum - 1
Set 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_name
If ListItem.selectSingleNode("baibai").nodeTypedValue = "2" Then
syubetu = "買"
Else
syubetu = "売"
End If
If ListItem.selectSingleNode("torihiki").nodeTypedValue = "22" Then
syubetu = "返済" & syubetu
End If
If ListItem.selectSingleNode("torihiki").nodeTypedValue = "21" Then
syubetu = "信用" & syubetu
End If
If ListItem.selectSingleNode("torihiki").nodeTypedValue = "23" Then
If syubetu = "買" Then
syubetu = "現引"
Else
syubetu = "現渡"
End If
End If
If InStr(syubetu, "現渡") > 0 Or InStr(syubetu, "現引") > 0 Then
Else
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 If
End 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_torikomi
doc.async = False
URL = 基底URL & "/ws-logout"
XML.Open "GET", URL, False
XML.send
doc.loadXML (XML.responseText)
If doc.documentElement.selectSingleNode("responseStatus").nodeTypedValue <> "OK" Then
GoTo Err:
End If
Set XML = Nothing
Set doc = Nothing
Exit Sub
Err:
Application.StatusBar = "エラーが発生しました" + vbCrLf + Err.Description
お気に入りの記事を「いいね！」で応援しよう
【毎日開催】
15記事にいいね！で1ポイント
© Rakuten Group, Inc.
