アンケート とりあえずできた
今日一日でかなり進んだ。
久々に一日の大半を使ってやってた気がします。
Excelのブックを貼れないのが残念ですが,まぁやってみます。
Excelには二つのシートを作ります。 アンケートシート と コード と名前をつけます。
アンケートシート はこんな感じ
セル 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
こんな感じの画面です。
テキストには
こういう感じでテキストがたまっていきます。
JScript側でかなり処理をしているので 以前のものよりだいぶすっきりです。
わたしの環境では一応動きました。(゚▽゚*)