Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。JavaScriptやJScript,HTAに最近はまってます。

アンケート とりあえずできた

今日一日でかなり進んだ。

久々に一日の大半を使ってやってた気がします。

Excelのブックを貼れないのが残念ですが,まぁやってみます。

Excelには二つのシートを作ります。 アンケートシート と コード と名前をつけます。

アンケートシート はこんな感じ
f:id:chemiphys:20190113014836p:plain

セル b1の値がタイトルに
セル a4から 設問
セル b4から 種別 入力規則で select check radio text multi に制限しています。
セル c4からが選択肢です 連番は 1-41 のように書く,選択肢の場合は,(半角カンマ)区切りで
do loopでa列に空白がでるまで見ているので,けっこうアバウトです。

コード にはつぎのを貼ります。

<!doctype html>
<html>
<head>
<meta charset="utf-8">
【タイトル】
<style type="text/css">
  table{border-collapse: collapse;}
  table,tr,td{border: solid 2px black;}
  td.clsmondai{padding-left: 5px;font-weight: bold;background-color: black;color: white;width:400px}
  td.clskaito{padding-left: 20px;background-color: antiquewhite}
  </style>
<script>
  var ForReading = 1;
  var ForWriting = 8;
  var p=[
【パラメータ配列】
  ]
  var thisName=location.pathname
  
  thisName=thisName.slice(thisName.lastIndexOf("\\")+1,thisName.lastIndexOf("."));
  var fso = new ActiveXObject("Scripting.FileSystemObject");
  if (fso.FolderExists(".\\data")==false) fso.CreateFolder(".\\data");
  var DataFile = ".\\data\\"+thisName+"data.txt";
  if (fso.FileExists(DataFile)==false){
    var data = fso.OpenTextFile(DataFile, ForWriting,true);
    var tmp="user"
    for (var i=0;i<p.length;i++){tmp+="◇"+p[i][1]}
    tmp+="◇Date"
    data.WriteLine(tmp);
    data.Close()
  } 
  var User=new ActiveXObject("WScript.Network").UserName;
  
  //ベタ打ちここまで
  
  function init(){
    resizeTo(500,600);
    makeForm()
  }
  
  function renban(s,e){
    var arr=[]
    for (var i=s;i<=e;i++) arr.push(i)
    return arr
  }
  
  function makeForm(){
    var tmp=[]
    tmp.push("<table>")
    for(var i=0;i<p.length;i++) tmp.push(makeElement(i))
    tmp.push("</table>")
    document.getElementById("table").innerHTML=tmp.join("")
  }
  
  function makeElement(No){
    var mondai=p[No][1]
    var name="No"+(No)
    var type=p[No][2]
    var arr=p[No][3]
    var html=[];
    var tmp;
    switch(type){
      case "select":tmp = makeSelectElement(name,"select",arr);break
      case "radio":tmp = makeSelectElement(name,"radio",arr);break
      case "check":tmp = makeSelectElement(name,"checkbox",arr);break
      case "text":tmp="<input type='text' name='" + name + "' size='45' />";break
      case "multi":tmp="<textarea name='" + name +"' rows='5' cols='46' ></textarea>";break
    }
    
    html.push("<tr><td class='clsmondai'>" + (No+1) + " " + mondai + "</td></tr>")
    html.push("<tr><td class='clskaito'>")
    html.push(tmp+"</td>")
    
    return html.join("")
  }

  function makeSelectElement(name,type,arr){
    switch(type){
      case "select":
        var tmp=[]
        tmp.push("<select name='" + name +"'>")
        for(var i=0;i<arr.length;i++){tmp.push("<option value='" + arr[i]+"'>"+arr[i]+"</option>")}
        tmp.push("</select>")
        element=tmp.join("")
        break
      case "radio":
      case "checkbox": //間違いじゃないよ
        var tmp=[]
        for(var i=0;i<arr.length;i++){
          tmp.push("<input type='"+ type +"' name='" + name + "' value='" + arr[i] +"'>"+arr[i]+"<br>")
        }
        element=tmp.join("")
        break

    }
    return element
  }
  // データ収集部分
  function result(){
    var html=[]
    html.push(User+"◇")
    for (var i=0;i<p.length;i++){
      html.push(getData("No"+i,p[i][2])+"◇")
    }
    html.push(Date())
    return html.join("")
  }

  function PostData(str){
    var fso = new ActiveXObject("Scripting.FileSystemObject");
    var data = fso.OpenTextFile(DataFile, ForWriting);
    data.WriteLine(result());
    data.Close();
    document.forms[0].reset()
  }
  function getData(name,type){
    switch(type){
      case "radio":
      case "check":
      return getCheck(name);
    break;
      case "text":
      case "multi":
      case "select":
    return document.getElementsByName(name)[0].value.replace(/\r?\n/g,"_");
    break;
    }
  }
    
  function getCheck(name){
      var CHECK=document.getElementsByName(name)
      var tmp=""
      for(var i=0;i<CHECK.length;i++){
        if(CHECK[i].checked) tmp+="_" +CHECK[i].value
      }
      return tmp.substring(1)
  }
</script>
</head>
<body onload="init()">
  <form id="formFld">
    <div id="table"></div>
    <input type="button" href="#" value="送信する" onClick="PostData()"/>
  </form>
</body>
</html>

[END]

wordに一度貼ってからexcelに貼るといいかも。 最後の[END]は大事です。
これがないと永久ループに・・ DoEventsは入れてるので止めてあげればいいですが。

HTAを吐き出すコードが次

Sub MakeHTAFile()
    Dim CodeSheet As Worksheet: Set CodeSheet = ThisWorkbook.Worksheets("コード")
    Dim ConfigSheet As Worksheet: Set ConfigSheet = ThisWorkbook.Worksheets("アンケートシート")
    
    Dim ADODBStream As Object
    Set ADODBStream = CreateObject("ADODB.Stream")
    With ADODBStream
        .Charset = "UTF-8"
        .Open
    End With
    
    Dim i, j, k, tmp, tmp2, tmp3
    
    i = 1
    Do
        Select Case CodeSheet.Cells(i, 1)
            Case Is = "【タイトル】"
                ADODBStream.writetext "<title>" & ConfigSheet.Cells(1, 2) & "</title>", 1
            Case Is = "【パラメータ配列】"
                j = 1
                Do While ConfigSheet.Cells(j + 3, 1) <> ""
                    tmp = ConfigSheet.Cells(j + 3, 3)
                    If InStr(tmp, ",") > 0 Then tmp2 = "['" & Replace(tmp, ",", "','") & "']"
                    If InStr(tmp, "-") > 0 Then tmp2 = "renban(" & Split(tmp, "-")(0) & "," & Split(tmp, "-")(1) & ")"  '数式に,が出るから上のコードとの順番注意
                    If tmp = "" Then tmp2 = "''"
                    tmp3 = "    [" & j & ",'" & ConfigSheet.Cells(j + 3, 1) & "','" & ConfigSheet.Cells(j + 3, 2) & "'," & tmp2 & "],"
                    If ConfigSheet.Cells(j + 3 + 1, 1) = "" Then tmp3 = Left(tmp3, Len(tmp3) - 1)
                    ADODBStream.writetext tmp3, 1
                    j = j + 1
                Loop
            Case Else
                ADODBStream.writetext CodeSheet.Cells(i, 1), 1
        End Select
        i = i + 1
        DoEvents
    Loop Until CodeSheet.Cells(i, 1) = "[END]"
    
    Dim FileName As String
    FileName = ThisWorkbook.Path & "\" & ConfigSheet.Cells(1, 2) & ".hta"
    
    ADODBStream.savetofile FileName, 2
    ADODBStream.Close
    
End Sub

こんな感じの画面です。
f:id:chemiphys:20190113073539p:plain
テキストには
f:id:chemiphys:20190113073558p:plain
こういう感じでテキストがたまっていきます。
JScript側でかなり処理をしているので 以前のものよりだいぶすっきりです。

わたしの環境では一応動きました。(゚▽゚*)