MSDNフォーラムにあった質問「VBAでのフォーム オブジェクトを立体的なデザインから平面的なデザインにしたい」用に書いたコードです。
※ 64ビット版Officeで実行する場合は要修正
'UserForm1
'※ WebBrowserコントトール要配置
'※ Microsoft HTML Object Library(mshtml.tlb)要参照
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As Office.IAccessible, ByRef phwnd As Long) As Long
Private WithEvents btn1 As MSHTML.HTMLButtonElement
Private WithEvents btn2 As MSHTML.HTMLButtonElement
Private WithEvents btn3 As MSHTML.HTMLButtonElement
Private WithEvents btn4 As MSHTML.HTMLButtonElement
Private Sub UserForm_Initialize()
SetFormStyle
RenderHtml
End Sub
Private Sub SetFormStyle()
'ユーザーフォームの外観設定
Dim hForm As Long
Dim style As Long
WindowFromAccessibleObject Me, hForm
If hForm <> 0 Then
style = GetWindowLong(hForm, -16)
style = style Or &H40000
SetWindowLong hForm, -16, style
End If
End Sub
Private Sub RenderHtml()
'WebBrowserにHTML描画
Dim d As MSHTML.HTMLDocument
Dim src As String
With Me.WebBrowser1
.Navigate "about:blank"
While .Busy Or .ReadyState <> READYSTATE_COMPLETE
DoEvents
Wend
Set d = .Document
End With
src = "<!DOCTYPE html>" & vbNewLine
src = src & "<html lang=""ja"">" & vbNewLine
src = src & "<head>" & vbNewLine
src = src & " <meta charset=""utf-8"">" & vbNewLine
src = src & " <meta http-equiv=""X-UA-Compatible"" content=""IE=edge"">" & vbNewLine
src = src & " <link rel=""stylesheet"" href=""https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css"">" & vbNewLine
src = src & " <link rel=""stylesheet"" href=""https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap-theme.min.css"">" & vbNewLine
src = src & " <script src=""https://code.jquery.com/jquery-1.11.3.min.js""></script>" & vbNewLine
src = src & " <script src=""https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/js/bootstrap.min.js""></script>" & vbNewLine
src = src & " <style>" & vbNewLine
src = src & " *{padding:5px;}" & vbNewLine
src = src & " </style>" & vbNewLine
src = src & "</head>" & vbNewLine
src = src & "<body>" & vbNewLine
src = src & " <div class=""container"">" & vbNewLine
'ボタン追加
src = src & " <button id=""button1"" class=""btn btn-primary""><span class=""glyphicon glyphicon-globe""></span>button1</button>" & vbNewLine
src = src & " <button id=""button2"" class=""btn btn-success""><span class=""glyphicon glyphicon-cutlery""></span>button2</button>" & vbNewLine
src = src & " <button id=""button3"" class=""btn btn-info""><span class=""glyphicon glyphicon-folder-open""></span>button3</button>" & vbNewLine
src = src & " <button id=""button4"" class=""btn btn-danger""><span class=""glyphicon glyphicon-remove""></span>Close</button>" & vbNewLine
src = src & " </div>" & vbNewLine
src = src & "</body>" & vbNewLine
src = src & "</html>"
VBA.CallByName d, "write", VbMethod, src
Set btn1 = d.getElementById("button1")
Set btn2 = d.getElementById("button2")
Set btn3 = d.getElementById("button3")
Set btn4 = d.getElementById("button4")
End Sub
Private Function btn1_onclick() As Boolean
MsgBox btn1.ID, vbInformation
End Function
Private Function btn2_onclick() As Boolean
MsgBox btn2.ID, vbExclamation
End Function
Private Function btn3_onclick() As Boolean
MsgBox btn3.ID, vbCritical
End Function
Private Function btn4_onclick() As Boolean
Unload Me
End Function
Private Sub UserForm_Resize()
'ユーザーフォームに合わせてWebBrowserリサイズ
With Me.WebBrowser1
.Width = Me.Width
.Height = Me.Height
End With
End Sub
“平面的なデザイン”というのはよく分かりませんが、WebBrowser経由であれば「Bootstrap」等のフレームワークが利用できるので、既存のActiveXコントロールを使うよりも、デザイン性に優れたフォームに仕上げることができます。
余計なトラブルが発生する可能性もあるので、見た目にこだわりが無ければ既存のコントロールで十分だとは思いますが、「こういった方法も一応あるよ」ということで。
この記事へのコメントはありません。