GDIplusCODE


'☆ 標準モジュール
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

Sub execJScode()
    Dim objIE As InternetExplorer
    Dim doc As IHTMLDocument
    Dim myHeader As IHTMLElement
    Dim myBody As IHTMLElement
    Dim newElement As IHTMLElement
    Dim mybutton As IHTMLButtonElement
    Dim myScript As String
    Dim myResult As IHTMLElement
    Dim myResultArray As IHTMLUListElement
    Dim myListItem As IHTMLLIElement
    Dim myArray() As String
    Dim i As Long
     
    Set objIE = New InternetExplorer
    '可視、Trueで見えるようにします。
    objIE.Visible = True
    
    'これを入れないと、DOMの変更が反映されない
    '入れると、コードからの、doc.script.setTimeoutがセキィリティに引っかかる場合がある
    objIE.navigate "about:blank"
    
    Set doc = objIE.document
    
    doc.write "<html><head></head><body></body></html>"
    Set myHeader = doc.getElementsByTagName("head")(0)
    Set myBody = doc.getElementsByTagName("body")(0)
    Set newElement = doc.createElement("SCRIPT")
    newElement.Type = "text/javascript"
    myScript = ActiveSheet.Shapes("TextBox 1").TextFrame.Characters.Text
    If myScript = "" Then Exit Sub
    newElement.Text = myScript
    myHeader.appendChild newElement
     
    'アクセスが拒否されましたというエラーになる
    'doc.script.setTimeout "myjscode()", 10
    
    '"about:blank"とは別ドメインからの実行とみなされるらしい。
    'かつては実行出来たと思うがセキュリティが厳しくなったものか。
    'イントラネットのセキュリティレベルを低にしてみたがNG
    'KB3025390が関係する 2014/12現在
    
    'これは苦肉の策
     Set mybutton = doc.createElement("button")
     mybutton.setAttribute "onclick", "myjscode();"
'     mybutton.innerText = "exec myjscode" '無くても可
     myBody.appendChild mybutton
     mybutton.Click
     myBody.RemoveChild mybutton  'オートメーションエラーになる時があるが原因不明
    
    '結果を受け取る
    '単独の値
    On Error Resume Next
     Set myResult = doc.getElementById("result")
     If Not myResult Is Nothing Then
      Set myResult = doc.getElementById("result")
     End If
     On Error GoTo 0
     
     '配列はliに入れてみる。
     On Error Resume Next
     Set myResultArray = doc.getElementById("Array")
     If Not myResultArray Is Nothing Then
        ReDim myArray(myResultArray.ChildNodes.Length)
        i = 1
        For Each myListItem In myResultArray.ChildNodes
          Debug.Print myListItem.innerText
          myArray(i) = myListItem.innerText
          i = i + 1
        Next myListItem       
     End If
     On Error GoTo 0
'    Sleep 50
'    DoEvents: DoEvents: DoEvents
'    生成されたソースの取得
'    Debug.Print doc.getElementsByTagName("html")(0).outerHTML
   
End Sub

'エクセルのシートに図形のTextBoxとボタン（これも図形にマクロ登録で可）を一個ずつ置く
'下記はTextBoxに記入したJavaScript Code（只の実行例です）
'大文字小文字の違い一文字でも動かないのでデバッグはきついです
’IE11の開発者ツールF12でデバッグできないものかと試していますが、うまくいっていません。

//VBAからはmyjscodeという関数名で実行する
//ここで別の関数に振り分ける
function myjscode() { test6();}
function test6(){
  var myArray = [1, 2, 3];
  //var num = myArray.length;
  addarray(myArray);
}
//関数の実行結果をdiv.id='Array'のliとして追記する
//VBAからは doc.getElementById("Array")で取得して、ループを回して行毎に処理する
function addarray(arr){
  var num = arr.length;
  document.write (num);
  
  var body = document.getElementsByTagName('body')[0]; 
  var ul = document.createElement('ul');
  ul.id='Array';
  body.appendChild(ul);
  for (var  i=0 ; i< num  ; i++){ 
  var li = document.createElement('li');
  li.innerText = arr[i];
  ul.appendChild(li);
  li=null;
  }
}
//関数の実行結果をdiv.id="result"のinnerTextとして追記する
//VBAからは doc.getElementById("result").innerTextとして取得できる
//引数は文字列で与えること。文字列への変換例：result.toString(10);
function addresult(result){
   var body = document.getElementsByTagName('body')[0];
  var div = document.createElement('div');
  div.id="result";
  div.innerText=result
  body.appendChild(div);
}


'IEを表示させない方法もやってみました。
'UserForm/WebBrowserを使用しているのは、CreatObjectしたIEを使用する場合、消し忘れの怖れがあるためです。

'☆ 標準モジュール
Sub test()
  Load UserForm1
' UserForm側でUnload Meするとうまくいかない様です
  Unload UserForm1
End Sub

'☆ UserForm1モジュール
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

'UserFormにはWebBrowserコントロールを一個だけ置きます。
’UserFormは表示させないで処理結果のみを示しています。
Private Sub UserForm_initialize()
    Dim objIE As WebBrowser
    Dim doc As IHTMLDocument
    Dim myElement As IHTMLElement
    Dim newElement As IHTMLElement
    Dim myScript As String
     
    Set objIE = Me.WebBrowser1
    Set doc = New HTMLDocument
    
    doc.write "<html><head></head><body></body></html>"
    Set myElement = doc.getElementsByTagName("head")(0)
    Set newElement = doc.createElement("SCRIPT")
    newElement.Type = "text/javascript"
    myScript = ActiveSheet.Shapes("TextBox 1").TextFrame.Characters.Text
    If myScript = "" Then Exit Sub
    newElement.Text = myScript
'    doc.body.appendChild newElementはOKだが、doc.headはエラーになる
    myElement.appendChild newElement
    
'　問題なく動きます
    doc.script.setTimeout "myjscode()", 10
    Sleep 50
    DoEvents: DoEvents: DoEvents
    Debug.Print doc.getElementsByTagName("html")(0).outerHTML
   
   Set myElement = doc.getElementById("result")
   MsgBox myElement.innerText
End Sub

Excel/VBAからJavaScriptのコードを実行してみる