アレ的な猫

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

おしまい。🙇‍♂️🙇‍♂️🙇‍♂️🙇‍♂️

VbのフォームをHTMLへ！！