[ Excel VBA for mac 16.35 ] 文字列をURIエンコードできません...

Question

環境

• mac OS 10.15.4
• Excel for mac 16.35(20030802)

実現したいこと

文字列をURIエンコードしたいです。

試したこと

1. JavaScript#encodeURI()を使う

Function UrlEncode(mySource As Variant) As String
    Dim objSC As Object
    Set objSC = CreateObject("ScriptControl")
    objSC.Language = "JScript"
    UrlEncode = objSC.CodeObject.encodeURIComponent(mySource)
    Set objSC = Nothing 
End Function

Sub test
    MsgBox UrlEncode("テスト")
End

** 結果 **
「ActiveXコンポーネントはオブジェクトを作成できません。」
とエラーが出ます。

---

2. rubyを使う

Private Declare PtrSafe Function popen Lib "libc.dylib" (ByVal command As String, ByVal mode As String) As LongPtr
Private Declare PtrSafe Function pclose Lib "libc.dylib" (ByVal file As LongPtr) As Long
Private Declare PtrSafe Function fread Lib "libc.dylib" (ByVal outStr As String, ByVal size As LongPtr, ByVal items As LongPtr, ByVal stream As LongPtr) As Long
Private Declare PtrSafe Function feof Lib "libc.dylib" (ByVal file As LongPtr) As LongPtr

Function execShell(command As String, Optional ByRef exitCode As Long) As String
    Dim file As LongPtr
    file = popen(command, "r")

    If file = 0 Then
        Exit Function
    End If

    While feof(file) = 0
        Dim chunk As String
        Dim read As Long
        chunk = Space(50)
        read = fread(chunk, 1, Len(chunk) - 1, file)
        If read > 0 Then
            chunk = Left$(chunk, read)
            execShell = execShell & chunk
        End If
    Wend

    exitCode = pclose(file)
End Function

Function UrlEncode(mySource As Variant) As String
    Dim command As String
    Dim result As String

    command = "do shell script ""ruby -r cgi -e 'puts CGI.escape(""" & mySource & """);'"""
    result = execShell(command, exitCode)
    UrlEncode = result
End Function

Sub test
    MsgBox UrlEncode("テスト")
End

** 結果 **
何もリターンされません。（空文字が返ります）
ターミナルでruby -r cgi -e 'puts CGI.escape("テスト");'を実行すると「%E3%83%86%E3%82%B9%E3%83%88」と返ります。

---

3. nkfを使う

Private Declare PtrSafe Function popen Lib "libc.dylib" (ByVal command As String, ByVal mode As String) As LongPtr
Private Declare PtrSafe Function pclose Lib "libc.dylib" (ByVal file As LongPtr) As Long
Private Declare PtrSafe Function fread Lib "libc.dylib" (ByVal outStr As String, ByVal size As LongPtr, ByVal items As LongPtr, ByVal stream As LongPtr) As Long
Private Declare PtrSafe Function feof Lib "libc.dylib" (ByVal file As LongPtr) As LongPtr

Function execShell(command As String, Optional ByRef exitCode As Long) As String
    Dim file As LongPtr
    file = popen(command, "r")

    If file = 0 Then
        Exit Function
    End If

    While feof(file) = 0
        Dim chunk As String
        Dim read As Long
        chunk = Space(50)
        read = fread(chunk, 1, Len(chunk) - 1, file)
        If read > 0 Then
            chunk = Left$(chunk, read)
            execShell = execShell & chunk
        End If
    Wend

    exitCode = pclose(file)
End Function

Function UrlEncode(mySource As Variant) As String
    Dim command As String
    Dim result As String

    command = "do shell script ""echo '" & mySource & "' | nkf -WwMQ | sed 's/=$//g' | tr = % | tr -d '\n'"""
    result = execShell(command, exitCode)
    UrlEncode = result
End Function

Sub test
    MsgBox UrlEncode("テスト")
End

** 結果 **
何もリターンされません。（空文字が返ります）
ターミナルでecho 'テスト' | nkf -WwMQ | sed 's/=$//g' | tr = % | tr -d '\n'を実行すると「%E3%83%86%E3%82%B9%E3%83%88」と返ります。

---

4. AppleScript経由でruby / nkfを使う

Function UrlEncode(mySource As Variant) As String
    Dim result As String

    result = AppleScriptTask("urlencode.applescript", "urlEncode", mySource)
    UrlEncode = result
End Function

Sub test
    MsgBox UrlEncode("テスト")
End

# ~/Library/Application Scripts/com.microsoft.Excel/urlencode.applescript
on urlEncode(inData)
    set scpt to "ruby -r cgi -e 'puts CGI.escape(""" & quote & inData & quote & """);'"
    return (do shell script scpt) as string
end urlEncode

** 結果 **
「プロシージャの呼び出し、または引数が無効です。」
とエラーが出ます。
（上はrubyですがnkfのコードも同じエラーになります）

---

何か良い方法がありましたら、ご教示いただけますと幸いです。
よろしくお願いいたします。

Answer 1

昔作成した、自作変換関数なのでバグがありますが参考となれば
http://www.ken3.org/cgi-bin/test/test097-3.asp?DATA=%93%5D%90E
http://www.ken3.org/asp/backno/asp097.html
(※URIだと、スペースを+に直したり、&の処理とか、工夫が必要ですが。。。。)
MACでCreateObject("ScriptControl")などが使えないなら作ってしまえ・・の安易な発想でした。

Sub Test() 'google検索テスト

    '検索文字を入力
    Dim strMOJI As String
    strMOJI = InputBox("キーワード=", "入力", "初日で辞めたくなった")

    '検索文字を作る
    Dim strPARA As String  'パラメーター
    strPARA = testUTF8(strMOJI) '関数を呼ぶ
    MsgBox strPARA
    
    '手抜きで Shell でWebページを表示する
    'Dim strURL As String
    'strURL = "http://www.google.co.jp/search?hl=ja&ie=UTF-8&q=" & strPARA
    'Call Shell("explorer.exe """ & strURL & """", vbNormalFocus)

End Sub

Function testUTF8(CHK_DATA)

    '文字数分ループして、コードを表示
    strUTF8 = "" '空文字で初期化
    For n = 1 To Len(CHK_DATA)
      strWORK = Mid(CHK_DATA, n, 1)  'ｎ番目の文字を取り出す
      '２バイト、漢字か判断 手抜きでLen関数で文字数を見た
      If Len(Hex(Asc(strWORK))) <= 2 Then
        If Asc(strWORK) <= &H20 Then
          '制御コードか？
          strCODE = "%" & Right("0" & Hex(Asc(strWORK)), 2)
        Else
          '英数はそのまま＋する
          strCODE = strWORK
        End If
      Else
        strCODE = SJIStoUTF8(strWORK)   '変換関数を呼ぶ
      End If
      strUTF8 = strUTF8 & strCODE   '結果の文字列をつなげる
    Next

    'リターン値を代入
    testUTF8 = strUTF8

End Function

'SJISコードの文字列を受け取り、UTF8コードの%付文字列を返す
Function SJIStoUTF8(strSJIS)

    strUNICODE = AscW(strSJIS)  'ASCWでユニコードにする

    'コードを２進にしてワークに代入する
    strWORK2 = HEX16toSTR2(Hex(strUNICODE))

    '切り取って、UTF8の２進数を作成する
    'xxxx xxxx xxxx xxxx を下記に割り当てる
    '1110xxxx 10xxxxxx 10xxxxxx
    strUTF8CODE = "1110" & Mid(strWORK2, 1, 4)
    strUTF8CODE = strUTF8CODE & "10" & Mid(strWORK2, 5, 6)
    strUTF8CODE = strUTF8CODE & "10" & Mid(strWORK2, 11, 6)

    '作成した２進数を１６進数に戻す
    strWORK16 = STR2toHEX16(strUTF8CODE)

    '%を付けて格納
    strRET = ""  'リターン値を初期化
    strRET = strRET & "%" & Mid(strWORK16, 1, 2) '%を付けた文字列を作成
    strRET = strRET & "%" & Mid(strWORK16, 3, 2)
    strRET = strRET & "%" & Mid(strWORK16, 5, 2)

    'リターン値を代入
    SJIStoUTF8 = strRET

End Function

'HEX16進文字列を受け取り2進数文字列を返す
Function HEX16toSTR2(strHEX)

    Dim n       'ループカウンタ
    Dim i       'ループのカウンタ
    Dim n8421   '8 4 2 1の数値計算用
    Dim str2STR

    Dim nCHK

    str2STR = ""  '結果のエリアを初期化する

    '文字数分ループする
    For n = 1 To Len(strHEX)
        On Error Resume Next   'エラー発生時次の行へ
        nCHK = 0 '0で初期化
        nCHK = CInt("&h" & Mid(strHEX, n, 1)) 'n文字目を数値変換
        On Error GoTo 0        'エラー処理を通常に戻す

        n8421 = 8  '初期値に８を代入する(上からチェックしたいので)
        For i = 1 To 4  '４回まわるよ
            If (nCHK And n8421) = 0 Then 'Andでビットをチェックする
                str2STR = str2STR & "0"  'ビットは立ってないよ
            Else
                str2STR = str2STR & "1"  'ビットは立ってるよ
            End If
            '次のビットをチェックしたいので２で割る
            n8421 = n8421 / 2
        Next
    Next

    'リターン値をセットして終了
    HEX16toSTR2 = str2STR

End Function

'2進文字列を受け取り16進文字列を返す
Function STR2toHEX16(str2)

    Dim strHEX
    Dim n       'ループカウンタ
    Dim i       'ループのカウンタ
    Dim n8421   '8 4 2 1の数値計算用
    Dim nBYTE

    '頭４文字単位かチェックする
    n = Len(str2) Mod 4      '足りない文字数を計算する
    If n <> 0 Then
       str2 = String(4 - n, "0") & str2 '頭に文字０を追加する
    End If

    strHEX = ""   '結果のエリアを初期化する

    '文字数分ループする
    For n = 1 To Len(str2) Step 4  '４文字(1バイト)単位にループを作る
        n8421 = 8  '初期値に８を代入する(上から計算したいので)
        nBYTE = 0  '1バイト計算用変数を初期化
        For i = 0 To 3  '４回まわるよ(4ビット分)
            'ビットが立っているかチェックする
            If Mid(str2, n + i, 1) = "1" Then
                nBYTE = nBYTE + n8421   'ビットに対応した数値を＋する
            End If
            '次のビットを計算したいので２で割る
            n8421 = n8421 / 2
        Next
        '計算して、１倍との数値が完成したので１６進文字にしてセットする
        strHEX = strHEX & Hex(nBYTE)
     Next

     'リターン値をセットして関数を抜ける
     STR2toHEX16 = strHEX

End Function

Comments

[ucndev]

ありがとうございます！
何がどうなっているのかコードを拝読してもまったく理解できませんが、まるっとコピーを使わせていただいたところ、意図通りの変換になりました！ありがとうございました！！

１つ、半角の「%」が「%25」にならずそのまま出力されておりましたが、「%25」にする方法がわからず、半角「%」を全角「％」に置換してからtestUTF8()に流すようにしました。