[VBA]ユーザーフォームでBootstrapを使う。

ホーム
Office関連, Excel, Word, PowerPoint
[VBA]ユーザーフォームでBootstrapを使う。

2015.10.19

[VBA]ユーザーフォームでBootstrapを使う。

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