'API関数
Private Declare PtrSafe Function InternetOpen _
            Lib "wininet.dll" _
          Alias "InternetOpenA" _
         (ByVal lpszAgent As String _
        , ByVal dwAccessType As Long _
        , ByVal lpszProxyName As String _
        , ByVal lpszProxyBypass As String _
        , ByVal dwFlags As Long) As Long
        
Private Declare PtrSafe Function InternetCloseHandle _
            Lib "wininet.dll" _
         (ByVal hInternet As Long) As Integer
         
Private Declare PtrSafe Function InternetConnect _
            Lib "wininet.dll" _
          Alias "InternetConnectA" _
         (ByVal hInternet As Long _
        , ByVal lpszServerName As String _
        , ByVal nServerPort As Integer _
        , ByVal lpszUsername As String _
        , ByVal lpszPassword As String _
        , ByVal dwService As Long _
        , ByVal dwFlags As Long _
        , ByVal dwContext As Long) As Long
        
Private Declare PtrSafe Function HttpOpenRequest _
            Lib "wininet.dll" _
          Alias "HttpOpenRequestA" _
         (ByVal hConnect As Long _
        , ByVal lpszVerb As String _
        , ByVal lpszObjectName As String _
        , ByVal lpszVersion As String _
        , ByVal lpszReferer As String _
        , ByVal lpszAcceptTypes As Long _
        , ByVal dwFlags As Long _
        , ByVal dwContext As Long) As Long
        
Private Declare PtrSafe Function HttpSendRequest _
            Lib "wininet.dll" _
          Alias "HttpSendRequestA" _
         (ByVal hRequest As Long _
        , ByVal lpszHeaders As String _
        , ByVal dwHeadersLength As Long _
        , ByVal lpOptional As String _
        , ByVal dwOptionalLength As Long) As Integer
        
Private Declare PtrSafe Function HttpQueryInfo _
            Lib "wininet.dll" _
          Alias "HttpQueryInfoA" _
         (ByVal hRequest As Long _
        , ByVal dwInfoLevel As Long _
        , ByRef lpvBuffer As Any _
        , ByRef lpdwBufferLength As Long _
        , ByRef lpdwIndex As Long) As Integer
        
Private Declare PtrSafe Function InternetReadFile _
            Lib "wininet.dll" _
         (ByVal hRequest As Long _
        , ByRef lpBuffer As Any _
        , ByVal dwNumberOfBytesToRead As Long _
        , ByRef lpdwNumberOfBytesRead As Long) As Integer

Private Declare PtrSafe Function HttpAddRequestHeaders _
            Lib "wininet.dll" _
          Alias "HttpAddRequestHeadersA" _
         (ByVal hHttpRequest As Long _
        , ByVal sHeaders As String _
        , ByVal lHeadersLength As Long _
        , ByVal lModifiers As Long) As Integer
       
Private Declare PtrSafe Function InternetSetCookie Lib "wininet.dll" _
       Alias "InternetSetCookieA" _
       (ByVal lpszUrlName As String, _
       ByVal lpszCookieName As String, _
       ByVal lpszCookieData As String) As Boolean

Private Declare PtrSafe Function InternetGetCookie Lib "wininet.dll" _
       Alias "InternetGetCookieA" _
       (ByVal lpszUrlName As String, _
       ByVal lpszCookieName As String, _
       ByVal lpszCookieData As String, _
       lpdwSize As Long) As Boolean

'API関数で使用する定数も定義
Private Const INTERNET_FLAG_RELOAD        As Long = &H80000000
Private Const INTERNET_FLAG_DONT_CACHE    As Long = &H4000000
Private Const INTERNET_FLAG_RESYNCHRONIZE As Long = &H800
Private Const INTERNET_FLAG_NEED_FILE     As Long = &H10
Private Const INTERNET_FLAG_HYPERLINK     As Long = &H400
Private Const INTERNET_FLAG_NO_COOKIES    As Long = &H80000
Private Const INTERNET_FLAG_NO_AUTO_REDIRECT As Long = &H200000
Private Const INTERNET_FLAG_SECURE = &H800000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H800000
Private Const INTERNET_FLAG_IGNORE_CERT_DATE_INVALID = &H800000
Private Const INTERNET_OPEN_TYPE_DIRECT    As Long = &H1
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = &H0
Private Const INTERNET_OPEN_TYPE_PROXY     As Long = &H3
Private Const INTERNET_FLAG_ASYNC       As Long = &H10000000
Private Const INTERNET_FLAG_FROM_CACHE  As Long = &H1000000
Private Const INTERNET_DEFAULT_HTTP_PORT   As Integer = 80
Private Const INTERNET_DEFAULT_HTTPS_PORT  As Integer = 443
Private Const INTERNET_SERVICE_HTTP   As Long = 3
Private Const HTTP_QUERY_CONTENT_TYPE     As Long = 1
Private Const HTTP_QUERY_CONTENT_LENGTH   As Long = 5
Private Const HTTP_QUERY_DATE             As Long = 9
Private Const HTTP_QUERY_LAST_MODIFIED    As Long = 11
Private Const HTTP_QUERY_STATUS_CODE      As Long = 19
Private Const HTTP_QUERY_RAW_HEADERS_CRLF As Long = 22
Private Const HTTP_QUERY_LOCATION          As Long = 33
Private Const HTTP_QUERY_SERVER           As Long = 37
Private Const HTTP_QUERY_SET_COOKIE       As Long = 43
Private Const HTTP_QUERY_COOKIE           As Long = 44
Private Const HTTP_QUERY_REQUEST_METHOD   As Long = 45
Private Const HTTP_ADDREQ_FLAG_ADD As Long = &H20000000
Private Const HTTP_ADDREQ_FLAG_REPLACE As Long = &H80000000
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const ERROR_INSUFFICIENT_BUFFER = 122

'定数定義
'環境によって変更してください
'*****************************************************************
'ダウンロードファイルの保存場所 ：ドキュメントフォルダ
Private Const SAVE_DER As String = "C:\Users\******\Documents"

'*****************************************************************

Private Const SAVE_FILE As String = "\000temp.tmp"
Private Const IDRANGE As String = "C4"
Private Const PASSRANGE As String = "E4"
Private Const USERRANGE As String = "C2"
Private Const ASSETRANGE As String = "B7"

'変数の定義
Private lngWinINet As Long
Private lngHttpHnd As Long
Private lngReqHnd  As Long
Private strBuffer  As String * 1024
Private lngLength  As Long
Private bytDataArea() As Byte
Private lngDataLength As Long
Private lngSavePos    As Long
Private idText As String
Private passText As String
Private PostData As String
Private c_dir As String


Sub login_Click()

    'IDとパスワードを取得
    idText = Range(IDRANGE).Value
    passText = Range(PASSRANGE).Value
    
    'IDチェック
    If Len(idText) = 0 Then
        MsgBox "IDを入力してください", vbExclamation
        Exit Sub
     End If
     
    'パスワードチェック
    If Len(passText) = 0 Then
        MsgBox "パスワードを入力してください", vbExclamation
        Exit Sub
     End If
     
    
    Dim lngRC     As Long
    Dim lngStatus As Long

    'インターネットサービスオープン
    lngRC = fcInternetOpen

    'HTTPサーバとの接続と切断
    If lngRC = 0 Then
        
       'HTTPサーバ接続
       lngRC = fcHTTPConnect("sec-sso.click-sec.com")
       
       'リクエストを初期化
       If lngRC = 0 Then
          lngRC = fcHTTPOpenRequest("POST", "/mk/")
       End If
       
       'リクエストを送信
       If lngRC = 0 Then
          Call fcHttpAddRequestHeaders("Referer: https://sec-sso.click-sec.com/")
          Call fcHttpAddRequestHeaders("Accept:text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8")
          Call fcHttpAddRequestHeaders("Accept-Language: ja,en-us;q=0.7,en;q=0.3")
          Call fcHttpAddRequestHeaders("Accept-Encoding: gzip, deflate")
          Call fcHttpAddRequestHeaders("Connection: keep-alive")
          PostData = "j_username=" + idText + "&j_password=" + passText + "&LoginForm=%DB%B8%DE%B2%DD&p=80"
          
          lngRC = fcHTTPSendRequest(PostData)
       End If
       lngRC = 0
       
       'HTTPステータスコードを取得
       If lngRC = 0 Then
          lngRC = fcHTTPQueryInfo(HTTP_QUERY_STATUS_CODE)
          
          'HTTPステータスコードを保存
          lngStatus = CLng(strBuffer)

          'HTTPステータスコードチェック
          If lngStatus < 200 Or lngStatus > 299 Then
             lngRC = 0
          End If

       End If
       

       'ダウンロード
       If lngRC = 0 Then
          lngSavePos = 0
          lngDataLength = 0
          lngRC = fcHTTPReadFile
       End If
       
      
       'ファイルを保存
       If lngRC = 0 Then
          lngRC = fcDataSave(SAVE_DER, SAVE_FILE)
       End If
       
       'HTTPリクエストクローズ
       Call fcHttpRequestClose
       
       '切断
       Call fcHTTPDisConnect
       
           Dim sCookieVal As String * 256
    Dim bRet As Boolean
    
       If lngRC = 0 Then
            'ソース解析
            Dim buf As String
            Dim tmp As Variant
            Dim dir_tmp As Variant
            Dim loginRes As Long
            Open SAVE_DER + SAVE_FILE For Input As #1
                Line Input #1, buf
            Close #1
            
            tmp = Split(buf, "<br>")
            loginRes = InStr(1, tmp(1), "様", vbBinaryCompare)
            If loginRes > 0 Then
                MsgBox "ログイン成功"
                
                'リンク先の取得
                dir_tmp = Split(buf, "https://kabu.click-sec.com/")
                dir_tmp = Split(dir_tmp(1), "/mk/")
                c_dir = dir_tmp(0)
                    
                Range("C2").Value = LTrim(Replace(tmp(1), vbLf, ""))
            Else
                MsgBox "ログイン失敗 ID、パスワードを確認してください"
                Range(USERRANGE).Value = ""
                Range(ASSETRANGE).Value = ""
            End If
            
            'ダウンロードファイル削除
            Kill SAVE_DER + SAVE_FILE
        End If
    End If
End Sub


Sub getAssets_Click()
    Dim lngRC     As Long
    Dim lngStatus As Long

    'インターネットサービスオープン
    lngRC = fcInternetOpen

    'HTTPサーバとの接続と切断
    If lngRC = 0 Then
        
       'HTTPサーバ接続
       lngRC = fcHTTPConnect("kabu.click-sec.com")
       
       'リクエストを初期化
       If lngRC = 0 Then
          lngRC = fcHTTPOpenRequest("GET", "/" + c_dir + "/mk/dispPaUserSheet.do")
       End If
       
       'リクエストを送信
       If lngRC = 0 Then
          Call fcHttpAddRequestHeaders("Referer: https://kabu.click-sec.com/" + c_dir + "/mk/dispKabuMenu.do")
          Call fcHttpAddRequestHeaders("Accept:text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8")
          Call fcHttpAddRequestHeaders("Accept-Language: ja,en-us;q=0.7,en;q=0.3")
          Call fcHttpAddRequestHeaders("Accept-Encoding: gzip, deflate")
          Call fcHttpAddRequestHeaders("Connection: keep-alive")
          PostData = ""
          
          lngRC = fcHTTPSendRequest(PostData)
       End If
       lngRC = 0
       
       'HTTPステータスコードを取得
       If lngRC = 0 Then
          lngRC = fcHTTPQueryInfo(HTTP_QUERY_STATUS_CODE)
          
          'HTTPステータスコードを保存
          lngStatus = CLng(strBuffer)

          'HTTPステータスコードチェック
          If lngStatus < 200 Or lngStatus > 299 Then
             lngRC = 0
          End If

       End If
       

       'ダウンロード
       If lngRC = 0 Then
          lngSavePos = 0
          lngDataLength = 0
          lngRC = fcHTTPReadFile
       End If
       
      
       'ファイルを保存
       If lngRC = 0 Then
          lngRC = fcDataSave(SAVE_DER, SAVE_FILE)
       End If
       
       'HTTPリクエストクローズ
       Call fcHttpRequestClose
       
       '切断
       Call fcHTTPDisConnect
       
       If lngRC = 0 Then
            'ソース解析
            Dim buf As String
            Dim tmp As Variant
            Dim loginRes As Long
            Dim docRes As Long
            Open SAVE_DER + SAVE_FILE For Input As #1
                Line Input #1, buf
            Close #1
            
            docRes = InStr(1, buf, "保有資産時価評価額合計", vbBinaryCompare)
            
            If docRes > 0 Then
                tmp = Split(buf, "保有資産時価評価額合計")
                tmp = Split(tmp(1), "円")
                loginRes = InStr(1, tmp(0), "right", vbBinaryCompare)
            End If
            
            If loginRes > 0 Then
                MsgBox "取得成功"
                Range(ASSETRANGE).Value = LTrim(Replace(Replace(tmp(0), vbLf, ""), "<div align=""right"">", ""))
            Else
                MsgBox "取得失敗"
                Range(ASSETRANGE).Value = ""
            End If
            
            Kill SAVE_DER + SAVE_FILE
        End If
    End If
End Sub

Sub logout_Click()
    
    Dim lngRC     As Long
    Dim lngStatus As Long

    'インターネットサービスオープン
    lngRC = fcInternetOpen

    'HTTPサーバとの接続と切断
    If lngRC = 0 Then
        
       'HTTPサーバ接続
       lngRC = fcHTTPConnect("kabu.click-sec.com")
       
       'リクエストを初期化
       If lngRC = 0 Then
          lngRC = fcHTTPOpenRequest("GET", "/" + c_dir + "/mobile-logout")
       End If
       
       'リクエストを送信
       If lngRC = 0 Then
          Call fcHttpAddRequestHeaders("Referer: https://kabu.click-sec.com/" + c_dir + "/mk/dispKabuMenu.do")
          Call fcHttpAddRequestHeaders("Accept:text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8")
          Call fcHttpAddRequestHeaders("Accept-Language: ja,en-us;q=0.7,en;q=0.3")
          Call fcHttpAddRequestHeaders("Accept-Encoding: gzip, deflate")
          Call fcHttpAddRequestHeaders("Connection: keep-alive")
          PostData = ""
          
          lngRC = fcHTTPSendRequest(PostData)
       End If
       lngRC = 0
       
       'HTTPステータスコードを取得
       If lngRC = 0 Then
          lngRC = fcHTTPQueryInfo(HTTP_QUERY_STATUS_CODE)
          
          'HTTPステータスコードを保存
          lngStatus = CLng(strBuffer)

          'HTTPステータスコードチェック
          If lngStatus < 200 Or lngStatus > 299 Then
             lngRC = 0
          End If

       End If
       

       'ダウンロード
       If lngRC = 0 Then
          lngSavePos = 0
          lngDataLength = 0
          lngRC = fcHTTPReadFile
       End If
       
      
       'ファイルを保存
       If lngRC = 0 Then
          lngRC = fcDataSave(SAVE_DER, SAVE_FILE)
       End If
       
       'HTTPリクエストクローズ
       Call fcHttpRequestClose
       
       '切断
       Call fcHTTPDisConnect
       
       
       If lngRC = 0 Then
            'ソース解析
            Dim buf As String
            Dim tmp As Variant
            Dim loginRes As Long
            Open SAVE_DER + SAVE_FILE For Input As #1
                Line Input #1, buf
            Close #1
            
            loginRes = InStr(1, buf, "ﾛｸﾞｱｳﾄ", vbBinaryCompare)
            If loginRes > 0 Then
                MsgBox "ログアウト成功"
                Range(USERRANGE).Value = ""
                Range(ASSETRANGE).Value = ""
            Else
                MsgBox "ログアウト失敗"
                Range(USERRANGE).Value = ""
                Range(ASSETRANGE).Value = ""
            End If
            
            Kill SAVE_DER + SAVE_FILE
        
        End If

    End If
    
End Sub


Function fcHTTPConnect(Server As String) As Long

    'APIの実行　接続
    lngHttpHnd = InternetConnect(lngWinINet _
                              , Server _
                              , INTERNET_DEFAULT_HTTPS_PORT _
                              , vbNullString _
                              , vbNullString _
                              , INTERNET_SERVICE_HTTP _
                              , 0 _
                              , 0)

    fcHTTPConnect = Err.LastDllError

End Function

Function fcHTTPDisConnect() As Long

    'APIの実行　切断
    Call InternetCloseHandle(lngHttpHnd)
    fcHTTPDisConnect = Err.LastDllError

End Function

Function fcInternetOpen() As Long

    'APIの実行　インターネットサービスオープン
    lngWinINet = InternetOpen(vbNullString _
                            , INTERNET_OPEN_TYPE_PRECONFIG _
                            , vbNullString _
                            , vbNullString _
                            , 0)

    'この関数の戻り値には、APIの処理結果コードを返します
    fcInternetOpen = Err.LastDllError

End Function

Function fcInternetClose() As Long

    'APIの実行　インターネットサービスクローズ
    Call InternetCloseHandle(lngWinINet)
    fcInternetClose = Err.LastDllError

End Function

Function fcHTTPOpenRequest(strMethod As String, strURL As String) As Long

    Dim tmpURL     As String * 255
    Dim lngSecFlag As Long
    lngSecFlag = INTERNET_FLAG_SECURE Or _
                 INTERNET_FLAG_IGNORE_CERT_CN_INVALID Or _
                 INTERNET_FLAG_IGNORE_CERT_DATE_INVALID Or _
                 INTERNET_FLAG_RELOAD

    'URL
    tmpURL = strURL

    'APIの実行　リクエスト初期化
    lngReqHnd = HttpOpenRequest(lngHttpHnd _
                              , strMethod _
                              , tmpURL _
                              , "HTTP/1.1" _
                              , vbNullString _
                              , 0 _
                              , lngSecFlag _
                              , 0)

    fcHTTPOpenRequest = Err.LastDllError

End Function

Function fcHTTPSendRequest(strPostData As String) As Long

    Dim strHeader   As String

    'ヘッダー情報
    strHeader = "Content-Type: application/x-www-form-urlencoded"
    
    'API実行　リクエスト送信
    Call HttpSendRequest(lngReqHnd _
                       , strHeader _
                       , Len(strHeader) _
                       , strPostData _
                       , Len(strPostData))

    fcHTTPSendRequest = Err.LastDllError

End Function

Function fcHttpRequestClose() As Long

    'APIの実行　インターネットサービスクローズ
    Call InternetCloseHandle(lngReqHnd)
    fcHttpRequestClose = Err.LastDllError

End Function

Function fcHTTPQueryInfo(lngInfoLevel As Long) As Long

    Dim tmpIndex As Long

    lngLength = 1024
    strBuffer = vbNullString
    tmpIndex = 0

    'APIの実行　応答を取得
    Call HttpQueryInfo(lngReqHnd _
                     , lngInfoLevel _
                     , ByVal strBuffer _
                     , lngLength _
                     , tmpIndex)

    fcHTTPQueryInfo = Err.LastDllError

End Function
Function fcHTTPReadFile() As Long

    Dim tmpIndex        As Long
    Dim lngSize         As Long
    Dim i               As Long
    Dim tmpBuffer(1023) As Byte

    'ファイルを受信
    Do

       strBuffer = vbNullString
       lngSize = 0

       'ファイルを取得
       Call InternetReadFile(lngReqHnd _
                           , tmpBuffer(0) _
                           , 1024 _
                           , lngSize)


       'データの保存
       If Err.LastDllError = 0 Then

          If lngSize = 0 Then
             Exit Do
          End If

          lngDataLength = lngDataLength + lngSize
          ReDim Preserve bytDataArea(lngDataLength)

          For i = 0 To lngSize - 1
              bytDataArea(lngSavePos) = tmpBuffer(i)
              lngSavePos = lngSavePos + 1
          Next

       End If

    Loop

    If lngDataLength > 0 Then
       ReDim Preserve bytDataArea(lngDataLength - 1)
    End If

    fcHTTPReadFile = Err.LastDllError

End Function

Function fcDataSave(strPath As String, strFileName) As Long

    'ADO.Stream
    Dim objADOStream As New ADODB.Stream
    Dim objFS        As Object
    
    Set objFS = CreateObject("Scripting.FilesystemObject")

    'バイナリモードで保存
    objADOStream.Type = adTypeBinary
    objADOStream.Open
    objADOStream.Write bytDataArea

    'データ上書き保存
    objADOStream.SaveToFile objFS.BuildPath(strPath, strFileName) _
                          , adSaveCreateOverWrite

    objADOStream.Close

    Set objFS = Nothing
    Set objADOStream = Nothing
    
    fcDataSave = Err.LastDllError

End Function
Function fcHttpAddRequestHeaders(pHeader As String) As Long

    Dim lngRC As Long

    'APIの実行　ヘッダー設定
    lngRC = HttpAddRequestHeaders(lngReqHnd _
                                , pHeader _
                                , Len(pHeader) _
                                , HTTP_ADDREQ_FLAG_REPLACE _
                               Or HTTP_ADDREQ_FLAG_ADD)

    fcHttpAddRequestHeaders = CBool(lngRC)

End Function