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

CombineRgn


【ファイル名】CombineRgn.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2021年05月23日
【更新日】2021年06月13日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】CombineRgn.zip
【説明】Windows APIのCombineRgn関数を使用し、穴の開いたフォームを表示するサンプルです。

画面

【外部リンク】Windows > Apps > Win32 > API > System Services > Sysinfoap.h > CombineRgn
【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Wingdi.h >  CreateRectRgnDeleteObjectGetDeviceCaps
【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Winuser.h >  GetDCReleaseDCSetWindowRgn
【外部リンク】Windows > Apps > Win32 > API > Windows and Messages > Winuser.h >  GetSystemMetrics
【外部リンク】Windows > Apps > Win32 > API > Windows Accessibility Features > Oleacc.h > WindowFromAccessibleObject

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="CombineRgn">
          <button id="ShowFormButton" label="フォームを表示" keytip="S"
                  supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit

' GetSystemMetrics
Const SM_CYCAPTION = 4
Const SM_CXFRAME = 32
Const SM_CYFRAME = 33
'Const SM_CXSIZEFRAME = SM_CXFRAME
'Const SM_CYSIZEFRAME = SM_CYFRAME
Const SM_CXEDGE = 45
Const SM_CYEDGE = 46

' CombineRgn nCombineMode
'Const RGN_AND = 1
'Const RGN_OR = 2
Const RGN_XOR = 3
'Const RGN_DIFF = 4
'Const RGN_COPY = 5
'Const RGN_MIN = RGN_AND
'Const RGN_MAX = RGN_COPY

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getsystemmetrics
  Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-createrectrgn
  Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-combinergn
  Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode 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/en-us/windows/win32/api/wingdi/nf-wingdi-getdevicecaps
  Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
  
  ' https://docs.microsoft.com/en-us/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/winuser/nf-winuser-setwindowrgn
  Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hWnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long

  ' 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
  
  ' 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
#Else
  Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
  Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As LongPtr) As Long
  Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
  Private Declare Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As Long) As Long
  Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#End If

Private Const LOGPIXELSX = 88 ' Logical pixels / inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels / inch in Y

#If Win64 Then
  Private myHwnd As LongPtr
  Dim hDC As LongPtr
#Else
  Private myHwnd As Long
  Dim hDC As Long
#End If

Private Property Get hWnd()
  WindowFromAccessibleObject Me, myHwnd ' フォームのハンドルを取得する
  hWnd = myHwnd
End Property

Private Sub UserForm_Initialize() ' 初期化
#If Win64 Then
  Dim hForm As LongPtr
  Dim hImage As LongPtr
#Else
  Dim hForm As Long
  Dim hImage As Long
#End If
  Dim XPixelsPerInch As Long
  Dim YPixelsPerInch As Long
  Dim iTop    As Long
  Dim iLeft   As Long
  Dim iBottom As Long
  Dim iRight  As Long
          
  hDC = GetDC(hWnd)
  XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
  YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
  ReleaseDC hWnd, hDC

  With Image1
    iLeft = .Left * XPixelsPerInch / 72 + GetSystemMetrics(SM_CXEDGE) ' + GetSystemMetrics(SM_CXSIZEFRAME)
    iTop = .Top * YPixelsPerInch / 72 + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYEDGE) ' + GetSystemMetrics(SM_CYSIZEFRAME) '
    iRight = iLeft + (.Width * XPixelsPerInch / 72)
    iBottom = iTop + (.Height * YPixelsPerInch / 72)
  End With
  
  hForm = CreateRectRgn(0, 0, Me.Width * XPixelsPerInch / 72, Me.Height * YPixelsPerInch / 72)
  hImage = CreateRectRgn(iLeft, iTop, iRight, iBottom)
  Call CombineRgn(hForm, hForm, hImage, RGN_XOR)
  Call DeleteObject(hImage)
  Call SetWindowRgn(hWnd, hForm, 1)
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
このページの上