アレ的な猫
VbのフォームをなんとHTMLに出せるのだ！！🎊🎊
Option Compare Database
Option Explicit
' DPI設定
Const DEFAULT_DPI As Integer = 96
' デフォルト設定
Const DEFAULT_FONT_NAME As String = "Arial"
Const DEFAULT_FONT_SIZE As Integer = 10
Const DEFAULT_FONT_BOLD As Boolean = False
Const DEFAULT_FONT_ITALIC As Boolean = False
Const DEFAULT_FORE_COLOR As Long = vbBlack ' #000000
Const DEFAULT_BACK_COLOR As Long = vbWhite ' #FFFFFF
Const DEFAULT_BORDER_STYLE As Integer = 1 ' 実線
' システムカラー定数
Const COLOR_SCROLLBAR = 0
Const COLOR_BACKGROUND = 1
Const COLOR_ACTIVECAPTION = 2
Const COLOR_INACTIVECAPTION = 3
Const COLOR_MENU = 4
Const COLOR_WINDOW = 5
Const COLOR_WINDOWFRAME = 6
Const COLOR_MENUTEXT = 7
Const COLOR_WINDOWTEXT = 8
Const COLOR_CAPTIONTEXT = 9
Const COLOR_ACTIVEBORDER = 10
Const COLOR_INACTIVEBORDER = 11
Const COLOR_APPWORKSPACE = 12
Const COLOR_HIGHLIGHT = 13
Const COLOR_HIGHLIGHTTEXT = 14
Const COLOR_BTNFACE = 15
Const COLOR_BTNSHADOW = 16
Const COLOR_GRAYTEXT = 17
Const COLOR_BTNTEXT = 18
Const COLOR_INACTIVECAPTIONTEXT = 19
Const COLOR_BTNHIGHLIGHT = 20
Const COLOR_2NDACTIVECAPTION = 27 ' Win98以降
Const COLOR_2NDINACTIVECAPTION = 28 ' Win98以降
' Windows API関数の宣言（PtrSafe追加）
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
' コントロールの構造を保持するカスタム型
Type ControlInfo
Name As String
TypeName As String
Left As Long
Top As Long
Width As Long
Height As Long
FontName As String
FontSize As Integer
FontBold As Boolean
FontItalic As Boolean
ForeColor As Long
BackColor As Long
BorderStyle As Integer
Caption As String
Parent As String ' 親コンテナの名前
End Type
' Twipsをピクセルに変換する関数
Private Function TwipsToPixels(twips As Long, dpi As Integer) As Long
TwipsToPixels = twips * dpi / 1440
End Function
' 16進数カラーコードに変換する関数（システムカラー対応、αはオプション）
Private Function LongToHexColor(color As Long, Optional alpha As Byte = 255) As String
Dim r As Long, g As Long, b As Long
Dim isSystemColor As Boolean
isSystemColor = ((color And &HFF000000) = &H80000000)
If isSystemColor Then
Dim sysColorIndex As Long
sysColorIndex = color And &HFFFFFF
Dim sysColor As Long
sysColor = GetSysColor(sysColorIndex)
r = sysColor Mod 256
g = (sysColor \ 256) Mod 256
b = (sysColor \ 65536) Mod 256
Else
r = color Mod 256
g = (color \ 256) Mod 256
b = (color \ 65536) Mod 256
End If
If alpha = 255 Then
LongToHexColor = "#" & Right("0" & Hex(r), 2) & Right("0" & Hex(g), 2) & Right("0" & Hex(b), 2)
Else
LongToHexColor = "rgba(" & r & ", " & g & ", " & b & ", " & (alpha / 255) & ")"
End If
End Function
' フォームレイアウトをHTMLとして出力
Public Sub ExportFormToHTML(formName As String, Optional customDPI As Integer = DEFAULT_DPI)
On Error GoTo ErrorHandler
Dim frm As Form
Dim ctrl As Control
Dim html As String
Dim errorLog As String
Dim dpi As Integer
Dim controls() As ControlInfo
Dim i As Integer, j As Integer
dpi = customDPI
DoCmd.OpenForm formName, acDesign, , , , acHidden
Set frm = Forms(formName)
' コントロール情報を収集
ReDim controls(frm.Controls.Count - 1)
i = 0
For Each ctrl In frm.Controls
On Error Resume Next
With controls(i)
.Name = ctrl.Name
.TypeName = TypeName(ctrl)
.Left = TwipsToPixels(ctrl.Left, dpi)
.Top = TwipsToPixels(ctrl.Top, dpi)
.Width = TwipsToPixels(ctrl.Width, dpi)
.Height = TwipsToPixels(ctrl.Height, dpi)
.FontName = IIf(HasProperty(ctrl, "FontName") And Len(ctrl.FontName) > 0, ctrl.FontName, DEFAULT_FONT_NAME)
.FontSize = IIf(HasProperty(ctrl, "FontSize"), ctrl.FontSize, DEFAULT_FONT_SIZE)
.FontBold = IIf(HasProperty(ctrl, "FontBold"), ctrl.FontBold, DEFAULT_FONT_BOLD)
.FontItalic = IIf(HasProperty(ctrl, "FontItalic"), ctrl.FontItalic, DEFAULT_FONT_ITALIC)
.ForeColor = IIf(HasProperty(ctrl, "ForeColor"), ctrl.ForeColor, DEFAULT_FORE_COLOR)
.BackColor = IIf(HasProperty(ctrl, "BackColor"), ctrl.BackColor, DEFAULT_BACK_COLOR)
.BorderStyle = IIf(HasProperty(ctrl, "BorderStyle"), ctrl.BorderStyle, DEFAULT_BORDER_STYLE)
If HasProperty(ctrl, "Caption") Then .Caption = ctrl.Caption
.Parent = ""
' TabControl内のPageの子を特定
If HasProperty(ctrl, "Parent") And Not IsNull(ctrl.Parent) Then
If TypeName(ctrl.Parent) = "Page" Then
.Parent = ctrl.Parent.Name ' Pageの名前
End If
End If
End With
If Err.Number <> 0 Then
errorLog = errorLog & "Error in control '" & ctrl.Name & "': " & Err.Description & vbCrLf
Err.Clear
End If
On Error GoTo ErrorHandler
i = i + 1
Next ctrl
' PageをTabControlに紐づけ
For i = 0 To UBound(controls)
If controls(i).TypeName = "Page" Then
For j = 0 To UBound(controls)
If controls(j).TypeName = "TabControl" Then
If controls(i).Left >= controls(j).Left And controls(i).Top >= controls(j).Top And _
controls(i).Left + controls(i).Width <= controls(j).Left + controls(j).Width And _
controls(i).Top + controls(i).Height <= controls(j).Top + controls(j).Height Then
controls(i).Parent = controls(j).Name
End If
End If
Next j
End If
Next i
' OptionGroupやSubformの座標ベース親子関係（TabControl/Pageの子を除外）
For i = 0 To UBound(controls)
If controls(i).Parent = "" And controls(i).TypeName <> "Page" And controls(i).TypeName <> "TabControl" Then
For j = 0 To UBound(controls)
If i <> j And (controls(j).TypeName = "OptionGroup" Or controls(j).TypeName = "Subform") Then
With controls(i)
' TabControl領域外のコントロールのみを対象
Dim inTabControl As Boolean
inTabControl = False
For k = 0 To UBound(controls)
If controls(k).TypeName = "TabControl" Then
If .Left >= controls(k).Left And .Top >= controls(k).Top And _
.Left + .Width <= controls(k).Left + controls(k).Width And _
.Top + .Height <= controls(k).Top + controls(k).Height Then
inTabControl = True
Exit For
End If
End If
Next k
If Not inTabControl And _
.Left >= controls(j).Left And .Top >= controls(j).Top And _
.Left + .Width <= controls(j).Left + controls(j).Width And _
.Top + .Height <= controls(j).Top + controls(j).Height Then
.Parent = controls(j).Name
End If
End With
End If
Next j
End If
Next i
' HTMLヘッダー
html = "<!DOCTYPE html>" & vbCrLf
html = html & "<html lang=""ja"">" & vbCrLf
html = html & "<head>" & vbCrLf
html = html & " <meta charset=""UTF-8"">" & vbCrLf
html = html & " <title>" & frm.Name & "</title>" & vbCrLf
html = html & " <style>" & vbCrLf
html = html & " body { margin: 0; padding: 0; font-family: " & DEFAULT_FONT_NAME & "; }" & vbCrLf
html = html & " .form-container { position: relative; width: " & TwipsToPixels(frm.Width, dpi) & "px; height: " & TwipsToPixels(frm.InsideHeight, dpi) & "px; border: 1px solid #000; background-color: " & LongToHexColor(frm.Section(acDetail).BackColor) & "; }" & vbCrLf
html = html & " .control, .container { position: absolute; box-sizing: border-box; }" & vbCrLf
html = html & " .container { background-color: transparent; }" & vbCrLf
html = html & " input[type=""text""] { border: 1px solid #000; }" & vbCrLf
html = html & " button { border: 1px solid #000; }" & vbCrLf
html = html & " label { display: block; }" & vbCrLf
html = html & " select { border: 1px solid #000; }" & vbCrLf
html = html & " </style>" & vbCrLf
html = html & "</head>" & vbCrLf
html = html & "<body>" & vbCrLf
html = html & " <div class=""form-container"">" & vbCrLf
' 最上位コントロールを再帰的に出力
For i = 0 To UBound(controls)
If controls(i).Parent = "" Then
html = html & GenerateControlHTML(controls, i, dpi, 4, 0, 0)
End If
Next i
' HTMLフッター
html = html & " </div>" & vbCrLf
If Len(errorLog) > 0 Then
html = html & " <pre style=""color: red;"">=== Error Log ===<br>" & errorLog & "</pre>" & vbCrLf
End If
html = html & "</body>" & vbCrLf
html = html & "</html>"
' UTF-8でファイル出力
Dim filePath As String
filePath = CurrentProject.Path & "\Form_" & formName & ".html"
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2 ' adTypeText
.Charset = "UTF-8"
.Open
.WriteText html
.SaveToFile filePath, 2 ' adSaveCreateOverWrite
.Close
End With
Set stream = Nothing
DoCmd.Close acForm, formName, acSaveNo
MsgBox "Form exported to HTML (UTF-8): " & filePath, vbInformation
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbCritical
DoCmd.Close acForm, formName, acSaveNo
If Not stream Is Nothing Then stream.Close
End Sub
' コントロールのHTMLを再帰的に生成（親の座標を引数に追加）
Private Function GenerateControlHTML(controls() As ControlInfo, index As Integer, dpi As Integer, indentLevel As Integer, parentLeft As Long, parentTop As Long) As String
Dim html As String
Dim style As String
Dim i As Integer
Dim indent As String
Dim relativeLeft As Long
Dim relativeTop As Long
indent = String(indentLevel, " ")
With controls(index)
' 親コンテナの座標を引いて相対座標に変換
relativeLeft = .Left - parentLeft
relativeTop = .Top - parentTop
style = "style=""left: " & relativeLeft & "px; top: " & relativeTop & "px; width: " & .Width & "px; height: " & .Height & "px; "
style = style & "font-family: " & .FontName & "; font-size: " & .FontSize & "pt; "
If .FontBold Then style = style & "font-weight: bold; "
If .FontItalic Then style = style & "font-style: italic; "
style = style & "color: " & LongToHexColor(.ForeColor) & "; "
style = style & "background-color: " & LongToHexColor(.BackColor) & "; "
Select Case .BorderStyle
Case 0: style = style & "border: none; "
Case 1: style = style & "border: 1px solid #000; "
Case Else: style = style & "border: 1px dashed #000; "
End Select
style = style & """"
Select Case .TypeName
Case "TabControl"
html = indent & "<div class=""container tab-control"" " & style & ">" & vbCrLf
For i = 0 To UBound(controls)
If controls(i).Parent = .Name Then ' Pageを処理
html = html & GenerateControlHTML(controls, i, dpi, indentLevel + 2, .Left, .Top)
End If
Next i
html = html & indent & "</div>" & vbCrLf
Case "Page"
html = indent & "<div class=""container page"" " & style & ">" & vbCrLf
For i = 0 To UBound(controls)
If controls(i).Parent = .Name Then
html = html & GenerateControlHTML(controls, i, dpi, indentLevel + 2, .Left, .Top)
End If
Next i
html = html & indent & "</div>" & vbCrLf
Case "OptionGroup"
html = indent & "<div class=""container option-group"" " & style & ">" & vbCrLf
html = html & indent & " <legend>" & .Name & "</legend>" & vbCrLf
For i = 0 To UBound(controls)
If controls(i).Parent = .Name Then
html = html & GenerateControlHTML(controls, i, dpi, indentLevel + 2, .Left, .Top)
End If
Next i
html = html & indent & "</div>" & vbCrLf
Case "Subform"
html = indent & "<div class=""container subform"" " & style & ">" & vbCrLf
For i = 0 To UBound(controls)
If controls(i).Parent = .Name Then
html = html & GenerateControlHTML(controls, i, dpi, indentLevel + 2, .Left, .Top)
End If
Next i
html = html & indent & "</div>" & vbCrLf
Case "Label"
html = indent & "<label class=""control"" " & style & ">" & .Caption & "</label>" & vbCrLf
Case "TextBox"
html = indent & "<input type=""text"" class=""control"" " & style & " value=""" & .Name & """ name=""" & .Name & """>" & vbCrLf
Case "CommandButton"
html = indent & "<button class=""control"" " & style & ">" & .Caption & "</button>" & vbCrLf
Case "ComboBox"
html = indent & "<select class=""control"" " & style & "><option>" & .Name & "</option></select>" & vbCrLf
Case Else
html = indent & "<div class=""control"" " & style & ">[" & .TypeName & ": " & .Name & "]</div>" & vbCrLf
End Select
End With
GenerateControlHTML = html
End Function
' プロパティの存在を確認する補助関数
Private Function HasProperty(obj As Object, propName As String) As Boolean
On Error Resume Next
Call VBA.CallByName(obj, propName, VbGet)
HasProperty = (Err.Number = 0)
Err.Clear
On Error GoTo 0
End Function
' 使用例（テスト用メイン、変更なし）
Public Sub TestExportToHTML()
ExportFormToHTML "フォーム1", 96
End Sub
オマケ
Sub SplitTextByLineBreakWithColorAndInsertRows()
Dim ws As Worksheet
Dim rng As Range, cell As Range
Dim inputRange As Range
Dim textArray() As String
Dim i As Long, j As Long, k As Long
Dim maxLines As Long
Dim charColors() As Long '文字ごとの色を記録する配列
'ワークシートを設定
Set ws = ActiveSheet
'処理する範囲をユーザーに選択させる
On Error Resume Next
Set inputRange = Application.InputBox("範囲を選択してください", Type:=8)
On Error GoTo 0
If inputRange Is Nothing Then
MsgBox "範囲が選択されていません。終了します。"
Exit Sub
End If
'範囲内で最大の改行数を調べる
maxLines = 0
For Each cell In inputRange
If Not IsEmpty(cell) Then
textArray = Split(cell.Value, vbLf)
If UBound(textArray) > maxLines Then
maxLines = UBound(textArray)
End If
End If
Next cell
'必要に応じて行を挿入
If maxLines > 0 Then
ws.Rows(inputRange.Row + 1 & ":" & inputRange.Row + maxLines).Insert Shift:=xlDown
End If
'範囲をループして処理
For Each cell In inputRange
If Not IsEmpty(cell) Then
'改行で文字列を分割
textArray = Split(cell.Value, vbLf)
'文字ごとの色を記録する配列を準備
ReDim charColors(1 To Len(cell.Value))
For j = 1 To Len(cell.Value)
If Not IsNull(cell.Characters(j, 1).Font.Color) Then
charColors(j) = cell.Characters(j, 1).Font.Color
Else
charColors(j) = vbBlack 'デフォルトは黒
End If
Next j
'元のセルと挿入した行に文字列を配置
For i = LBound(textArray) To UBound(textArray)
If Len(textArray(i)) > 0 Then
'出力先セルに文字列を書き込み
ws.Cells(cell.Row + i, cell.Column).Value = textArray(i)
'文字ごとの色を適用
Dim startPos As Long
startPos = 1
For k = LBound(textArray) To i - 1
startPos = startPos + Len(textArray(k)) + 1 '改行分を加算
Next k
For j = 1 To Len(textArray(i))
Dim srcPos As Long
srcPos = startPos + j - 1
If srcPos <= UBound(charColors) Then
ws.Cells(cell.Row + i, cell.Column).Characters(j, 1).Font.Color = charColors(srcPos)
End If
Next j
End If
Next i
End If
Next cell
MsgBox "処理が完了しました！"
End Sub
おしまい。🙇♂️🙇♂️🙇♂️🙇♂️
