ソースコード表示テスト

Sub TestUploadFile()
    Dim rstr As String
    Dim rstr2 As String
    Dim file_path As String

    'Debug.Print "UploadFile"

    file_path = ThisWorkbook.Path & "\" & "猫アイコン128x128.png"
    rstr = UploadFile(file_path, "猫アイコン128x128.png")

    Dim jsonObj As Object
    Set jsonObj = ParseJson(rstr)
    Debug.Print jsonObj("id")
    Debug.Print jsonObj("name")
    Debug.Print jsonObj("size")

'    Debug.Print "DBODB_UploadFile"
'    rstr2 = UploadFile_NoBOM(file_path, "猫アイコン128x128.png")
'    Set jsonObj = ParseJson(rstr2)
'    Debug.Print jsonObj("id")
'    Debug.Print jsonObj("name")
'    Debug.Print jsonObj("size")
    
End Sub

Public Function UploadFile(file_path, file_name) As String
    If C_UPLOAD_CNT >= 500 Then
        MsgBox "アップロード回数が500に達しました。システム制限によりこれ以上はアップロードできません!"
        UploadFile = "UPLOAD LIMIT 500"
        Exit Function
    End If
    Dim WS1 As Worksheet
    Set WS1 = □基本設定
    Dim spaURL As String
    Dim apiURL As String
    Dim apiKey As String
    
    spaURL = WS1.Range("B3")
    apiKey = WS1.Range("B4")
    apiURL = "/api/v2/space/attachment"
    
    Dim Url As String
    Url = spaURL & apiURL & "?" & "apiKey" & "=" & apiKey
    
    ' ファイルの情報設定
    Dim mimeType As String
    mimeType = "application/octet-stream" 'ファイルのmime-type
    
    Const adTypeBinary = 1
    Const adTypeText = 2
    Dim BOUNDARY As String
    Dim END_BOUNDARY As String
    BOUNDARY = "---------------------------BOUNDARY"
    END_BOUNDARY = vbCrLf & "--" & BOUNDARY & "--" & vbCrLf & vbCrLf
    
    '1. アップロードするファイルを読みだす
    Dim fileContents
    Dim stream: Set stream = CreateObject("ADODB.Stream")
    stream.Type = adTypeBinary
    stream.Open
    stream.LoadFromFile file_path
    fileContents = stream.Read
    stream.Close
    
    '2. マルチパートのデータ構成手順の記述
    Dim params As String: params = ""
    params = params & "--" & BOUNDARY & vbCrLf
    params = params & "Content-Disposition: form-data; name=""" & "file" & """;"
    params = params & " filename=""" & file_name & """" & vbCrLf
    params = params & "Content-Type: " & mimeType & vbCrLf & vbCrLf
    
    'VBA内部はUNIコードなのでUTF-8への変換を実行
    Dim aByte() As Byte
    aByte = ToUTF8(params)
    
    ' バイナリデータの前まで
    stream.Open
    stream.position = 0
    stream.Type = adTypeBinary
    stream.Write aByte
  
    ' バイナリデータ
    stream.Write fileContents
    
    ' 最後
    aByte = ToUTF8(END_BOUNDARY)
    stream.Write aByte
    
    Dim formData
    ChangeStreamType stream, adTypeBinary
    stream.position = 0
    formData = stream.Read
    stream.Close
    
    ' HTTPSリクエスト
    Dim http As New MSXML2.XMLHTTP60
    http.Open "POST", Url, False
    http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
    http.send formData
    If http.Status <> 200 Then
        Dim errCnt As Long
        errCnt = errCnt + 1
        If errCnt < 2 Then
            MsgBox ("HTTP エラー " & http.Status & " " & http.statusText)
        End If
        Debug.Print Format(Now(), "yyyy/mm/dd hh:mm:ss ") & http.ResponseText & " " & http.Status & " " & http.statusText
    End If
    C_UPLOAD_CNT = C_UPLOAD_CNT + 1
    UploadFile = http.ResponseText
 
End Function

Function ChangeStreamType(stream, t)
    Dim p As Long
    p = stream.position
    stream.position = 0
    stream.Type = t
    stream.position = p
    Set ChangeStreamType = stream
End Function

色々思い出してます・・・

f:id:gyokusen_since:20200802132417p:plain

私の好きな猫画像
Sub TestUploadFile()
    Dim rstr As String
    Dim rstr2 As String
    Dim file_path As String

    'Debug.Print "UploadFile"

    file_path = ThisWorkbook.Path & "\" & "猫アイコン128x128.png"
    rstr = UploadFile(file_path, "猫アイコン128x128.png")

    Dim jsonObj As Object
    Set jsonObj = ParseJson(rstr)
    Debug.Print jsonObj("id")
    Debug.Print jsonObj("name")
    Debug.Print jsonObj("size")

'    Debug.Print "DBODB_UploadFile"
'    rstr2 = UploadFile_NoBOM(file_path, "猫アイコン128x128.png")
'    Set jsonObj = ParseJson(rstr2)
'    Debug.Print jsonObj("id")
'    Debug.Print jsonObj("name")
'    Debug.Print jsonObj("size")
    
End Sub

Public Function UploadFile(file_path, file_name) As String
    If C_UPLOAD_CNT >= 500 Then
        MsgBox "アップロード回数が500に達しました。システム制限によりこれ以上はアップロードできません!"
        UploadFile = "UPLOAD LIMIT 500"
        Exit Function
    End If
    Dim WS1 As Worksheet
    Set WS1 = □基本設定
    Dim spaURL As String
    Dim apiURL As String
    Dim apiKey As String
    
    spaURL = WS1.Range("B3")
    apiKey = WS1.Range("B4")
    apiURL = "/api/v2/space/attachment"
    
    Dim Url As String
    Url = spaURL & apiURL & "?" & "apiKey" & "=" & apiKey
    
    ' ファイルの情報設定
    Dim mimeType As String
    mimeType = "application/octet-stream" 'ファイルのmime-type
    
    Const adTypeBinary = 1
    Const adTypeText = 2
    Dim BOUNDARY As String
    Dim END_BOUNDARY As String
    BOUNDARY = "---------------------------BOUNDARY"
    END_BOUNDARY = vbCrLf & "--" & BOUNDARY & "--" & vbCrLf & vbCrLf
    
    '1. アップロードするファイルを読みだす
    Dim fileContents
    Dim stream: Set stream = CreateObject("ADODB.Stream")
    stream.Type = adTypeBinary
    stream.Open
    stream.LoadFromFile file_path
    fileContents = stream.Read
    stream.Close
    
    '2. マルチパートのデータ構成手順の記述
    Dim params As String: params = ""
    params = params & "--" & BOUNDARY & vbCrLf
    params = params & "Content-Disposition: form-data; name=""" & "file" & """;"
    params = params & " filename=""" & file_name & """" & vbCrLf
    params = params & "Content-Type: " & mimeType & vbCrLf & vbCrLf
    
    'VBA内部はUNIコードなのでUTF-8への変換を実行
    Dim aByte() As Byte
    aByte = ToUTF8(params)
    
    ' バイナリデータの前まで
    stream.Open
    stream.position = 0
    stream.Type = adTypeBinary
    stream.Write aByte
  
    ' バイナリデータ
    stream.Write fileContents
    
    ' 最後
    aByte = ToUTF8(END_BOUNDARY)
    stream.Write aByte
    
    Dim formData
    ChangeStreamType stream, adTypeBinary
    stream.position = 0
    formData = stream.Read
    stream.Close
    
    ' HTTPSリクエスト
    Dim http As New MSXML2.XMLHTTP60
    http.Open "POST", Url, False
    http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
    http.send formData
    If http.Status <> 200 Then
        Dim errCnt As Long
        errCnt = errCnt + 1
        If errCnt < 2 Then
            MsgBox ("HTTP エラー " & http.Status & " " & http.statusText)
        End If
        Debug.Print Format(Now(), "yyyy/mm/dd hh:mm:ss ") & http.ResponseText & " " & http.Status & " " & http.statusText
    End If
    C_UPLOAD_CNT = C_UPLOAD_CNT + 1
    UploadFile = http.ResponseText
 
End Function

Function ChangeStreamType(stream, t)
    Dim p As Long
    p = stream.position
    stream.position = 0
    stream.Type = t
    stream.position = p
    Set ChangeStreamType = stream
End Function

これとどこが違うのか?

>|javascript|
<script>
let codes = document.getElementsByClassName('code');
[].forEach.call(codes, function(elem, key, val){
// クラスに lang が含まれていない場合は何もしない
if (!/lang/.test(elem.className)) {
return;
}
let line_num = 1;
// 行で分割
let lines = elem.innerHTML.split("\n");
let texts = elem.textContent.split("\n");
// 最終行が空の時は削除
if (lines[lines.length-1].length === 0) {
lines.pop();
}
// 最初の1行目にコメント後の数字:か、数字:があれば、先頭の行番号にする(2017/4/15修正)
if ((texts.length > 0) && (/(^|\/\/|\/\*) *[0-9]+:/.test(texts[0].trim()))) {
line_num = texts[0].trim().replace(/:/, "").replace(/(\/\/|\/\*)/, "")-0;
lines.shift();
}
let modi = "<ol start='"+line_num+"'>";
lines.forEach(function(elem) {
modi += "<li class='code-list'>"+elem+"</li>";
});
modi += "</ol>";
elem.innerHTML = modi;
});
</script>
<script defer>
;(function(d){

if(!window.getSelection){
return
}

var btn = d.createElement("button")
btn.id = "selectPre"
btn.textContent = "select"
btn.addEventListener("click", selectPre, false)

function selectPre(){
var sel = window.getSelection()
var pre = this.parentNode
sel.selectAllChildren(pre)
sel.extend(pre, pre.childNodes.length-1)
}


var pres = d.getElementsByTagName("pre")
for(var i=pres.length; i--;){
pres[i].addEventListener("mouseover", addBtn, false)
}

function addBtn(e){
if(this === addBtn.ele) return // not to addBtn if already
this.appendChild(btn)
return addBtn.ele = this
}

})(document)
</script>
<script type="text/javascript">
window.addEventListener("load", function onLoad() {
window.removeEventListener("load", onLoad);
var codes = document.querySelectorAll("pre.code");
var len = codes.length;
for (var i = 0; i < len; i++) {
(function () {
var code = codes[i];
// select all on double click
code.addEventListener("dblclick", function () {
var range = document.createRange();
range.selectNodeContents(code);
var selection = document.getSelection();
selection.removeAllRanges();
selection.addRange(range);
});
})();
}
});
</script>
||<

ファイルのアップロードで嵌った話・・・

バックログAPIWikiページや課題の詳細にファイル添付するためのやり取りがある。それを実装しようとして3,4日嵌ったことがある。

結論としては以下の条件を守れば文字化けとかもなくバイナリーファイルをアップロードできることがわかった。

1.マルチパートのデータの日本語ファイル名の部分をUTF-8に変換して設定しないとサーバーエラーになってしまうことが分かった。

2.ADODBを使えばクリアできると思ったが何が悪いのかは確定していないがSJISでないとうまくいかなかった。

3.SJISで実施すると送付自体はうまくいくがファイル名が文字化けしてしまうことになった。そこでURLエンコードでファイル名を変換して送ってもサーバ側はデコードしてくれなくてがっかりだった。

4.最終的にヌーラボ社へ問合せてサンプルコードが欲しいといったらpysonスクリプトを送ってくれた。中身を調べるとやはりテキスト部分はUTF-8へ変換するのにバイト配列で設定する方式だった。
5.最終的にそれをVBAで真似をしたら上手くいきました。

 暫くぶりでソースコード貼り付けたら上手く変換してくれなくて困った・・・

「編集みたまま」の隣のタブ「HTML編集」でソースコードを以下のタグで挟んでやれば上手くいくことが分かった。

<pre class="code VBA" data-lang="VBA" data-unlink>

ここにソースコードを直接入れる

</pre>

 

Sub TestUploadFile()
    Dim rstr As String
    Dim rstr2 As String
    Dim file_path As String

    'Debug.Print "UploadFile"

    file_path = ThisWorkbook.Path & "\" & "猫アイコン128x128.png"
    rstr = UploadFile(file_path, "猫アイコン128x128.png")

    Dim jsonObj As Object
    Set jsonObj = ParseJson(rstr)
    Debug.Print jsonObj("id")
    Debug.Print jsonObj("name")
    Debug.Print jsonObj("size")

'    Debug.Print "DBODB_UploadFile"
'    rstr2 = UploadFile_NoBOM(file_path, "猫アイコン128x128.png")
'    Set jsonObj = ParseJson(rstr2)
'    Debug.Print jsonObj("id")
'    Debug.Print jsonObj("name")
'    Debug.Print jsonObj("size")
    
End Sub

Public Function UploadFile(file_path, file_name) As String
    If C_UPLOAD_CNT >= 500 Then
        MsgBox "アップロード回数が500に達しました。システム制限によりこれ以上はアップロードできません!"
        UploadFile = "UPLOAD LIMIT 500"
        Exit Function
    End If
    Dim WS1 As Worksheet
    Set WS1 = □基本設定
    Dim spaURL As String
    Dim apiURL As String
    Dim apiKey As String
    
    spaURL = WS1.Range("B3")
    apiKey = WS1.Range("B4")
    apiURL = "/api/v2/space/attachment"
    
    Dim Url As String
    Url = spaURL & apiURL & "?" & "apiKey" & "=" & apiKey
    
    ' ファイルの情報設定
    Dim mimeType As String
    mimeType = "application/octet-stream" 'ファイルのmime-type
    
    Const adTypeBinary = 1
    Const adTypeText = 2
    Dim BOUNDARY As String
    Dim END_BOUNDARY As String
    BOUNDARY = "---------------------------BOUNDARY"
    END_BOUNDARY = vbCrLf & "--" & BOUNDARY & "--" & vbCrLf & vbCrLf
    
    '1. アップロードするファイルを読みだす
    Dim fileContents
    Dim stream: Set stream = CreateObject("ADODB.Stream")
    stream.Type = adTypeBinary
    stream.Open
    stream.LoadFromFile file_path
    fileContents = stream.Read
    stream.Close
    
    '2. マルチパートのデータ構成手順の記述
    Dim params As String: params = ""
    params = params & "--" & BOUNDARY & vbCrLf
    params = params & "Content-Disposition: form-data; name=""" & "file" & """;"
    params = params & " filename=""" & file_name & """" & vbCrLf
    params = params & "Content-Type: " & mimeType & vbCrLf & vbCrLf
    
    'VBA内部はUNIコードなのでUTF-8への変換を実行
    Dim aByte() As Byte
    aByte = ToUTF8(params)
    
    ' バイナリデータの前まで
    stream.Open
    stream.position = 0
    stream.Type = adTypeBinary
    stream.Write aByte
  
    ' バイナリデータ
    stream.Write fileContents
    
    ' 最後
    aByte = ToUTF8(END_BOUNDARY)
    stream.Write aByte
    
    Dim formData
    ChangeStreamType stream, adTypeBinary
    stream.position = 0
    formData = stream.Read
    stream.Close
    
    ' HTTPSリクエスト
    Dim http As New MSXML2.XMLHTTP60
    http.Open "POST", Url, False
    http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
    http.send formData
    If http.Status <> 200 Then
        Dim errCnt As Long
        errCnt = errCnt + 1
        If errCnt < 2 Then
            MsgBox ("HTTP エラー " & http.Status & " " & http.statusText)
        End If
        Debug.Print Format(Now(), "yyyy/mm/dd hh:mm:ss ") & http.ResponseText & " " & http.Status & " " & http.statusText
    End If
    C_UPLOAD_CNT = C_UPLOAD_CNT + 1
    UploadFile = http.ResponseText
 
End Function

Function ChangeStreamType(stream, t)
    Dim p As Long
    p = stream.position
    stream.position = 0
    stream.Type = t
    stream.position = p
    Set ChangeStreamType = stream
End Function

久しぶりの投稿になった・・・

最近VBAバックログヌーラボ社のプロジェクト管理ツール)のバッチ登録や保存・復元の支援ツールを作成した。詳細については今後提示します。ヌーラボ社のライブラリにはVBAのものはないので一からつくりました。今後はEXCELの表形式のデータをWikiページへ自動生成したり、課題詳細に自動生成したりする機能を追加予定です。後カスタム項目(主に不具合管理表、仕様変更管理表、Q&A等を想定)について必須項目ありにするとなかなか入力のハードルが高くなりすぐに標題だけ入れてあとで詳細等を入れるやり方ができないのでこれを改善するための必要項目が不足している課題種別についてリストアップして入力者にお知らせできるようにするツールも開発しようかと考えています。

 

f:id:gyokusen_since:20200727211051p:plain

バックログ支援ツール

f:id:gyokusen_since:20200727211231p:plain

保存と復元

 

ちょっと不思議な現象

頼みもしないのに勝手に半角英字が全角英字に変換されてしまう現象が出た。

f:id:gyokusen_since:20191213144625p:plain

半角文字が全角に変換されてしまった・・・

実はコードウィンドウの該当部分をコピーしてここに張り付けた場合でも全角に変換されていた。その後いろいろテキストをいじっていたら出なくなった!?

<全角に一部変換されるケース>

Msg_L59 = "Log.txt がすでにオープンされているため書き込めません!" & vbCrLf & _
"Log.txt を閉じてください。" & vbCrLf & _
"Log.txt を閉じることができない場合は「キャンセル」ボタンをクリックしてください"
'Msg_L59 = StrConv(Msg_L59, vbNarrow)
RC = MsgBox(Msg_L59, vbOKCancel, "■ファイルオープンエラー")
If RC = vbOK Then
Resume
End If

===

<全角に変換されないケース>

Msg_L59 = "Log.txt がすでにオープンされているため書き込めません!" & vbCrLf & _
"Log.txt を閉じてください。" & vbCrLf & _
"Log.txt を閉じることができない場合は「キャンセル」ボタンをクリックしてください"
'Msg_L59 = StrConv(Msg_L59, vbNarrow)
RC = MsgBox(Msg_L59, vbOKCancel, "■ファイルオープンエラー")
If RC = vbOK Then
Resume
End If

当初はMsg_L59 = StrConv(Msg_L59, vbNarrow)のおまじないで全角に変換されるのは解消できていたがあまりにも不思議なので色々いじって試していたらこうなりました。

まだ再現できてません>全角に変換されるにはどういう条件が必要なんだろう?