kintoneでデータの検索やWEB共有、エクセルでデータの詳細表示＆編集

kintone_excel_upload

Sub ボタン2_Click()


    ' kintoneアクセス情報の設定
    subdomain = "" 'サブドメイン
    authToken = "" '「ユーザID : パスワード」のbase64エンコードした文字列
    AppNo = "" 'kintoneアプリの番号

    '確認ダイアログ
    Dim Ans As Integer
    Ans = MsgBox("kintoneへアップロードしますか？", vbYesNo + vbQuestion, "確認")
    If Ans = vbNo Then
        Exit Sub
    End If


    '--------------------------------------------------------------------
    '  変数定義
    '--------------------------------------------------------------------
    Dim objHttpReq As MSXML2.XMLHTTP   ' XMLHTTP オブジェクト
    Dim strJSON As String              ' レスポンスで受け取るJSONデータ
    Dim strURL As String               ' アクセス先URL
    Dim strQuery As String             ' 検索文字列
     
    '------------------------------------------------------------------
    ' Web API用に、アクセス先URLを作成する
    '------------------------------------------------------------
    strURL = "https://" + subdomain + ".cybozu.com/k/v1/record.json?&app=" + AppNo
    
    '------------------------------------------------------------------
    ' XMLHTTP オブジェクトを生成する
    '------------------------------------------------------------------
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    objHttpReq.Open "POST", strURL, False
    '------------------------------------------------------------------
    ' XMLHTTP のリクエストヘッダーを指定する
    '------------------------------------------------------------------
    ' ログイン認証
    objHttpReq.setRequestHeader "X-Cybozu-Authorization", authToken
    'ドメイン名：ポート番号
    objHttpReq.setRequestHeader "Host", subdomain + ".cybozu.com" + ":443"
    objHttpReq.setRequestHeader "Content-Type", "application/json"
    'キャッシュ対策（常にレスポンスが取得できる状態にする）
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"



    'レコード番号が無かったら、とりあえずkintoneレコードを生成する
    If Range("a1") = "" Then
        
        '------------------------------------------------------------------
        ' リクエストを送信する(エクセルデータからkintoneレコード生成)
        '------------------------------------------------------------------
        strName = Range("B3")
        strAddress = Range("B4")
        
        '添付ファイル無しで、とりあえずレコード生成
        strInsertJSON = "{""app"":" + AppNo + ",""record"":{""氏名"":{""value"":""" + strName + """},""住所"":{""value"":""" + strAddress + """}}}"
        objHttpReq.send (strInsertJSON)
        
        '------------------------------------------------------------------
        ' レスポンスを取得する
        '------------------------------------------------------------------
        'レスポンス情報を変数に格納する
        strJSON = objHttpReq.responseText
    
        'レコード番号を取得してセルに格納
        RecNo = Replace(strJSON, "{""id"":""", "")
        RecNo = Replace(RecNo, """,""revision"":""1""}", "")
        Range("a1") = RecNo

    End If
    
'↑↑↑↑ここまでがexcelデータから、kintoneのレコードを生成する処理↑↑↑↑
    
    
'↓↓↓↓ここから自分自身のファイルをアップロードしてfilekeyを取得する処理↓↓↓↓

    'アップロード用に自身をコピーしたtmpファイルを生成(自分自身をファイルオープンできないため)
    tmpFile = ThisWorkbook.Path + "\tmp.xlsm"
    ThisWorkbook.SaveCopyAs tmpFile

    ' ファイルの情報設定
    localfileName = tmpFile 'アップロード元のファイル
    Filename = ThisWorkbook.Name 'アップロード後のファイル名
    
    'ファイルのmime-type, 参照URL http://technet.microsoft.com/ja-jp/library/ee309278(v=office.12).aspx
    mimeType = "application/vnd.ms-excel.sheet.macroEnabled.12"

    
    Const adTypeBinary = 1
    Const adTypeText = 2
    Boundary = "---------------------------9223d5ca69cc69903961a3c3126146c2"
    END_BOUNDARY = vbCrLf + "--" + Boundary + "--" + vbCrLf
    
    Dim fileContents
    Dim stream: Set stream = CreateObject("ADODB.Stream")
    stream.Type = adTypeBinary
    stream.Open
    stream.LoadFromFile localfileName
    fileContents = stream.Read
    stream.Close
    
    Dim params: params = ""
    params = params + "--" + Boundary + vbCrLf
    params = params + "Content-Disposition: form-data; name=""" + "file" + """;"
    params = params + " filename=""" + Filename + """" + vbCrLf
    params = params + "Content-Type:" + mimeType + vbCrLf + vbCrLf
    
    stream.Type = adTypeText
    stream.Charset = "UTF-8"
    stream.Open
    
    ' バイナリデータの前まで
    ChangeStreamType stream, adTypeText
    stream.WriteText params
    
    ' バイナリデータ
    ChangeStreamType stream, adTypeBinary
    stream.Write fileContents
    
    ' 最後
    ChangeStreamType stream, adTypeText
    stream.WriteText END_BOUNDARY
    
    ChangeStreamType stream, adTypeBinary
    stream.Position = 0
    formData = stream.Read
    stream.Close
    
    ' HTTPSリクエスト
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    http.Open "POST", "https://" + subdomain + ".cybozu.com/k/v1/file.json", False
    http.setRequestHeader "X-Cybozu-Authorization", authToken
    
    http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Boundary
    
    http.send formData
    
    ' fileKeyの取得(３日間使われないと、削除されるらしい)
    FileKey = http.responseText
    
    'ローカルにある、アップロード用に自身をコピーしたtmpファイルを削除
    Kill localfileName
    
    

'↓↓↓↓ここからfilekeyを使って、レコードとエクセルファイルをひもづけるUPDATE処理↓↓↓↓

    ' リソース更新の時はPUT（POSTではない）
    objHttpReq.Open "PUT", strURL, False
    '------------------------------------------------------------------
    ' XMLHTTP のリクエストヘッダーを指定する
    '------------------------------------------------------------------
    ' ログイン認証
    objHttpReq.setRequestHeader "X-Cybozu-Authorization", "QWRtaW5pc3RyYXRvcjpxOEZNd21pcw=="
    ' Basic 認証
    'objHttpReq.setRequestHeader "Authorization", "Basic " & <ベーシック認証情報>
    'ドメイン名：ポート番号
    objHttpReq.setRequestHeader "Host", subdomain + ".cybozu.com" + ":443"
    objHttpReq.setRequestHeader "Content-Type", "application/json"
    
    'キャッシュ対策（常にレスポンスが取得できる状態にする）
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"

    '------------------------------------------------------------------
    ' リクエストを送信する(レコード番号に対応するkintoneレコードに、自己ファイルを添付する)
    '------------------------------------------------------------------
    Dim str_id As String
    str_id = Range("A1").Value
    strName = Range("B3")
    strAddress = Range("B4")
    
    '既存レコードに添付ファイル(他の値も更新されている可能性があるのでUPDATEDする)
    strUpdateJSON = "{""app"":" + AppNo + ",""id"":" + str_id + ",""record"":{""氏名"":{""value"":""" + strName + """},""住所"":{""value"":""" + strAddress + """},""添付ファイル"":{""value"":[" + FileKey + "]}}}"
    
    objHttpReq.send (strUpdateJSON)
    
    '------------------------------------------------------------------
    ' レスポンスを取得する
    '------------------------------------------------------------------
    'レスポンス情報を変数に格納する
    strJSON = objHttpReq.responseText
    MsgBox ThisWorkbook.Name + vbCrLf + strJSON + vbCrLf + "アップロードされました"

End Sub

Function ChangeStreamType(stream, t)
    p = stream.Position
    stream.Position = 0
    stream.Type = t
    stream.Position = p
    Set ChangeStreamType = stream
End Function