今回は項目の背景色をコントロールする機能を追加しました。
前提として私の環境(Windows10)ではできておりますので、コードは以下を参照してください。
<html>
<head>
<meta charset="UTF-8">
<HTA:APPLICATION
ID="HTAExcelTool"
BORDER="dialog"
CAPTION="yes"
SCROLL="no"
/>
<title>Excel 可変列入力ツール</title>
<style>
body {
font-family: Meiryo;
}
select{
width:120px;
height:24px;
font-size:14px;
}
option{
background-color: Window;
}
/* 基本情報の入力欄 */
#txtFolder, #txtFile, #txtSheet {
width:200px;
}
/* 開始列と開始行 */
#txtStartCol, #txtStartRow {
width:100px;
}
/* 入力項目 */
#inputArea input {
width:165px;
}
table{
border-collapse: collapse;
margin-top: 10px;
border: 1px solid black;
}
td{
padding: 4px 10px;
border: 1px solid black;
text-align:center;
}
</style>
<script language="VBScript">
Dim maxCols
maxCols = 10
' ==========================
' 初期化
' ==========================
Sub Init()
Dim i, opt
' 列数選択
For i = 1 To maxCols
Set opt = document.createElement("OPTION")
opt.value = i
opt.innerText = i & " 列"
colSelect.appendChild opt
Next
colSelect.value = 3
' 開始列（1～3）
For i = 1 To 3
Set opt = document.createElement("OPTION")
opt.value = i
opt.innerText = i
txtStartCol.appendChild opt
Next
txtStartCol.value = 2
' 開始行（1～5）
For i = 1 To 5
Set opt = document.createElement("OPTION")
opt.value = i
opt.innerText = i
txtStartRow.appendChild opt
Next
txtStartRow.value = 2
UpdateInputs
End Sub
' ==========================
' 列入力欄描画
' ==========================
Sub UpdateInputs()
Dim cols, i, html
If IsNumeric(colSelect.value) Then
cols = CLng(colSelect.value)
Else
cols = 1
End If
html = "<table><tr>"
' 見出し
For i = 1 To cols
html = html & "<td>項目" & i & "</td>"
Next
html = html & "</tr><tr>"
' 入力欄
For i = 1 To cols
html = html & "<td><input type='text' id='txt" & i & "'></td>"
Next
html = html & "</tr></table>"
inputArea.innerHTML = html
End Sub
' ==========================
' Excel作成
' ==========================
Sub CreateExcel()
Dim saveFolder, fileName, sheetName, fullPath
Dim xl, wb, i, cols
Dim startCol, startRow
Dim borderRows
Dim lastCol, lastRow
' -------- 基本入力 --------
saveFolder = Trim(txtFolder.value)
fileName = Trim(txtFile.value)
sheetName = Trim(txtSheet.value)
If saveFolder = "" Or fileName = "" Or sheetName = "" Then
MsgBox "格納先・ファイル名・シート名は必須です", 48
Exit Sub
End If
' -------- 数値安全取得 --------
If IsNumeric(txtStartCol.value) Then
startCol = CLng(txtStartCol.value)
Else
startCol = 1
End If
If IsNumeric(txtStartRow.value) Then
startRow = CLng(txtStartRow.value)
Else
startRow = 1
End If
If IsNumeric(txtBorderRows.value) Then
borderRows = CLng(txtBorderRows.value)
Else
borderRows = 1
End If
If borderRows < 1 Then borderRows = 1
' 列数
If IsNumeric(colSelect.value) Then
cols = CLng(colSelect.value)
Else
cols = 1
End If
' -------- 保存先 --------
If LCase(Right(fileName,5)) <> ".xlsx" Then
fileName = fileName & ".xlsx"
End If
fullPath = saveFolder & "\" & fileName
' -------- Excel操作 --------
Set xl = CreateObject("Excel.Application")
xl.Visible = False
xl.DisplayAlerts = False
Set wb = xl.Workbooks.Add()
wb.Sheets(1).Name = sheetName
' -------- データ入力 --------
For i = 1 To cols
wb.Sheets(1).Cells(startRow, startCol + i - 1).Value = document.getElementById("txt" & i).value
Next
' -------- 罫線 --------
lastCol = startCol + cols - 1
lastRow = startRow + borderRows
With wb.Sheets(1).Range( _
wb.Sheets(1).Cells(startRow, startCol), _
wb.Sheets(1).Cells(lastRow, lastCol) )
.Borders.LineStyle = 1
.Borders.Weight = 2
.Font.Name = fontSelect.value
End With
'--------------------------------------
' 背景色（項目行のみ）
Dim bgColor
bgColor = bgColorSelect.value
With wb.Sheets(1).Range( _
wb.Sheets(1).Cells(startRow, startCol), _
wb.Sheets(1).Cells(startRow, lastCol))
.Interior.Color = CLng("&H" & _
Mid(bgColor,6,2) & _
Mid(bgColor,4,2) & _
Mid(bgColor,2,2))
End With
' -------- 列幅 --------
If startCol <> 1 Then
wb.Sheets(1).Columns(1).ColumnWidth = _
wb.Sheets(1).Columns(1).ColumnWidth / 3
End If
' -------- 保存 --------
wb.SaveAs fullPath
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
MsgBox "Excel 作成完了" & vbCrLf & fullPath
End Sub
</script>
</head>
<body onload="Init">
<h3>Excel 作成ツール</h3>
<p style="font-weight:bold;color:blue;">
保存情報および開始位置・罫線設定を入力してください。
</p>
<table>
<tr>
<td>格納先</td>
<td>ファイル名</td>
<td>初回シート名</td>
<td>開始列</td>
<td>開始行</td>
</tr>
<tr>
<td><input id="txtFolder" type="text"></td>
<td><input id="txtFile" type="text" value="sample.xlsx"></td>
<td><input id="txtSheet" type="text" value="Sheet1"></td>
<td><select id="txtStartCol"></select></td>
<td><select id="txtStartRow"></select></td>
</tr>
</table>
<p style="font-weight:bold;color:blue;">
作成する列数と、各列の入力値を指定してください。
</p>
Excelの表の項目は何列にしますか？：
<select id="colSelect" onchange="UpdateInputs()"></select>
<div id="inputArea"></div>
<br>
<p style="font-weight:bold;color:blue;">
設定項目数は行数とフォントの種類を指定してください。
</p>
<table>
<tr>
<td>罫線行数</td>
<td>フォント</td>
<td>項目の背景色</td>
</tr>
<tr>
<td>
<input id="txtBorderRows" type="text" value="1">
</td>
<td>
<select id="fontSelect">
<option value="ＭＳ ゴシック">ＭＳ ゴシック</option>
<option value="メイリオ">メイリオ</option>
<option value="Arial">Arial</option>
</select>
</td>
<td>
<select id="bgColorSelect">
<option value="#CCFFFF">水色</option>
<option value="#CCFFCC">黄緑</option>
<option value="#CCCCCC">グレー</option>
</select>
</td>
</tr>
</table>
<br>
<button onclick="CreateExcel()">Excel 作成</button>
</body>
</html>