none
VBAでのフォーム オブジェクトを立体的なデザインから平面的なデザインにしたい RRS feed

すべての返信

  • 方法は無いはずです。

    VB.NETのフォームで使われているWindowsのコントロールはオーナードローという仕組みを使って見た目を変えることができます。ですが、VBAのフォームはOfficeアプリケーションが独自に実装しているもので、Windowsコントロールのように見た目を変えるための方法が提供されていません。

    あえて行うならImageコントロールを張り付けて使うということになるかと思います。


    甕星

    2015年10月18日 21:05
  • 質問者さんの「平面的なもの」が何を指しているのかわかりませんが、Windows 8から導入されたModern UIのことであれば、Officeを含む従来アプリケーションには無理で、Modern UI専用に1から作り直す必要があります。ですのでVBAでは実現できません。そもそもOfficeで実現されていないことをなぜVBAで実現したいのかが理解できません。
    2015年10月18日 21:22
  • こんにちは。

    WebBrowser経由であればBootstrap等のフレームワークやJSライブラリが使用できますので、ActiveXコントロールよりは自由度の高いデザインができるかと思います。

    'UserForm1
    '※ WebBrowserコントトール要配置
    '※ Microsoft HTML Object Library(mshtml.tlb)要参照
    
    Option Explicit
    
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    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 '外観は好みに応じて適当に設定
        style = style And Not &HC00000
        SetWindowLong hForm, -16, style
        DrawMenuBar hForm
      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 & "</head>" & vbNewLine
      src = src & "<body>" & vbNewLine
      src = src & "  <div class=""container"">" & vbNewLine
     
      'ボタン追加
      src = src & "    <button id=""button1"" class=""btn btn-primary"">button1</button>" & vbNewLine
      src = src & "    <button id=""button2"" class=""btn btn-success"">button2</button>" & vbNewLine
      src = src & "    <button id=""button3"" class=""btn btn-info"">button3</button>" & vbNewLine
      src = src & "    <button id=""button4"" class=""btn btn-danger"">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
      VBA.Unload Me
    End Function
    
    Private Sub UserForm_Resize()
    'ユーザーフォームに合わせてWebBrowserリサイズ
      With Me.WebBrowser1
        .Width = Me.Width
        .Height = Me.Height
      End With
    End Sub

    ただ、UIに強いこだわりが無いのであれば、標準的なコントロールを使用した方がトラブルは無いだろうと思います。
    2015年10月19日 2:41
  • 平面にしたいのはフォームそのものですか?それとも配置するコントロールですか?

    非常に原始的なやり方ですが、ボタンコントロールであれば4隅をラベルで塗りつぶすとか。

    Option Explicit
    
    Private Sub UserForm_Initialize()
    
    
        Dim c As Object
        Dim l As New Collection
        
        For Each c In Me.Controls
        
            Select Case TypeName(c)
            
                Case "CommandButton", "ToggleButton"
                    l.Add c
            
            End Select
            
        Next
        
        For Each c In l
            
            With Me.Controls.Add("Forms.Label.1")
                .Left = c.Left
                .Top = c.Top
                .Width = 2
                .Height = c.Height
            End With
        
            With Me.Controls.Add("Forms.Label.1")
                .Left = c.Left
                .Top = c.Top
                .Width = c.Width
                .Height = 2
            End With
        
            With Me.Controls.Add("Forms.Label.1")
                .Left = c.Left + c.Width - 2
                .Top = c.Top
                .Width = 2
                .Height = c.Height
            End With
        
            With Me.Controls.Add("Forms.Label.1")
                .Left = c.Left
                .Top = c.Top + c.Height - 2
                .Width = c.Width
                .Height = 2
            End With
        
        Next
    
    
    End Sub
    
    
    


    2015年11月11日 1:40