HOME > エクセルVBA > サンプル > Rectangle

Rectangle


【ファイル名】Rectangle.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年06月08日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】Rectangle.zip
【説明】Windows APIのRectangleを使用してユーザーフォームに四角形などを描画するサンプルです。線の描画は「LineTo.xlsm」を参照してください。
画面

【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Wingdi.h >  CreatePen functionCreateSolidBrush functionDeleteObject functionRectangle functionRoundRect functionEllipse functionSelectObject function
【外部リンク】Windows > Apps > Win32 > API > Windows GDI >  Winuser.h >  GetDC functionReleaseDC function
【外部リンク】Windows > Apps > Win32 > API > Windows Accessibility Features > Oleacc.h > WindowFromAccessibleObject function

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="Rectangle">
          <button id="ShowFormButton" label="フォームを表示" keytip="S"
                  supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit

' Pen Styles (wingdi.h)
Private Const PS_SOLID = 0
Private Const PS_DASH = 1       ' --------------
Private Const PS_DOT = 2        ' ..............
Private Const PS_DASHDOT = 3    ' _._._.__._._._
Private Const PS_DASHDOTDOT = 4 ' _.._..__.._.._
'Private Const PS_NULL = 5
'Private Const PS_INSIDEFRAME = 6
'Private Const PS_USERSTYLE = 7
'Private Const PS_ALTERNATE = 8
'Private Const PS_STYLE_MASK = &HF

#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-createpen
  Private Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-createsolidbrush
  Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
 
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-deleteobject
  Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-ellipse
  Private Declare PtrSafe Function Ellipse Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getdc
  Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-rectangle
  Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-releasedc
  Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
   
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-roundrect
  Private Declare PtrSafe Function RoundRect Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, _
                                                          ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-selectobject
  Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
              
  ' https://docs.microsoft.com/ja-jp/windows/desktop/api/oleacc/nf-oleacc-windowfromaccessibleobject
  Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As LongPtr) As Long

#Else
  Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
  Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  Private Declare Function RoundRect Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, _
                                                  ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
  Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  Private Declare Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As Long) As Long
#End If

#If Win64 Then
  Private hwnd As LongPtr ' ウィンドウのハンドル
  Private hdc As LongPtr  ' デバイス コンテキスト
#Else
  Private hwnd As Long ' ウィンドウのハンドル
  Private hdc As Long  ' デバイス コンテキスト
#End If

Private Sub CommandButton1_Click() ' 図形を描く
#If Win64 Then
  Dim NewPen As LongPtr ' 新しいペン
  Dim OldPen As LongPtr ' 元のペン
  Dim NewBrush As LongPtr ' 新しいブラシ
  Dim OldBrush As LongPtr ' 元のブラシ
#Else
  Dim NewPen As Long ' 新しいペン
  Dim OldPen As Long ' 元のペン
  Dim NewBrush As Long ' 新しいブラシ
  Dim OldBrush As Long ' 元のブラシ
#End If
  
  Repaint ' 描画のクリアー
  ' 四角形を描く
  NewPen = CreatePen(PS_SOLID, 1, VBA.ColorConstants.vbRed) ' ペンの作成
  OldPen = SelectObject(hdc, NewPen) ' 新しいペンを選択
  NewBrush = CreateSolidBrush(vbGreen) ' ブラシの作成
  OldBrush = SelectObject(hdc, NewBrush) ' 新しいブラシを選択
  Rectangle hdc, 10, 50, 100, 80 ' 四角形を描く
  SelectObject hdc, OldPen ' 元のペンに戻す
  DeleteObject NewPen ' ペンを削除
  SelectObject hdc, OldBrush ' 元のブラシに戻す
  DeleteObject NewBrush ' ブラシを削除
  ' 角丸の四角形を描く
  OldPen = SelectObject(hdc, CreatePen(PS_SOLID, 1, vbBlue)) ' 新しいペンを作成し選択
  OldBrush = SelectObject(hdc, CreateSolidBrush(RGB(128, 128, 128)))  ' 新しいブラシを作成し選択
  RoundRect hdc, 110, 50, 200, 80, 20, 10 ' 角丸の四角形を描く
  DeleteObject SelectObject(hdc, OldPen) ' 元のペンに戻し、ペンを削除
  DeleteObject SelectObject(hdc, OldBrush) ' 元のブラシに戻し、ブラシを削除
   ' 楕円形を描く
  OldPen = SelectObject(hdc, CreatePen(PS_SOLID, 1, vbYellow)) ' 新しいペンを作成し選択
  OldBrush = SelectObject(hdc, CreateSolidBrush(Excel.XlRgbColor.rgbAquamarine)) ' 新しいブラシを作成し選択
  Ellipse hdc, 210, 50, 300, 80 ' 楕円形を描く
  DeleteObject SelectObject(hdc, OldPen) ' 元のペンに戻し、ペンを削除
  DeleteObject SelectObject(hdc, OldBrush) ' 元のブラシに戻し、削除
End Sub

Private Sub UserForm_Initialize() ' 初期処理
  WindowFromAccessibleObject Me, hwnd ' フォームのハンドルを取得する
  hdc = GetDC(hwnd) ' デバイス コンテキストを取得する
End Sub

Private Sub UserForm_Terminate() ' 終了処理
  ReleaseDC hwnd, hdc ' デバイス コンテキストを解放する
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub
このページの上