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

CreatePen


【ファイル名】CreatePen.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年06月14日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】CreatePen.zip
【説明】Windows APIのCreatePenを使用してユーザーフォームにマウスで線を描画するサンプルです。

画面

【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Wingdi.h >  CreatePen functionDeleteObject functionGetDeviceCaps functionLineTo functionMoveToEx functionSelectObject function
【外部リンク】Windows > Apps > Win32 > API > Windows GDI >  Winuser.h >  GetDC functionReleaseDC function
【外部リンク】Windows > Apps > Win32 > API > Windows Accessibility Features > Oleacc.h > WindowFromAccessibleObject function
【外部リンク】Windows > Apps > Win32 > API > Display Devices Reference > Windef.h >  POINT structure

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

Option Explicit

' Pen Styles (wingdi.h)
Private Const PS_SOLID = 0

' GetDeviceCaps nIndex (wingdi.h)
Private Const LOGPIXELSX = 88 ' Logical pixels / inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels / inch in Y

' https://docs.microsoft.com/ja-jp/windows/win32/api/windef/ns-windef-point
Private Type POINTAPI ' Windef.h (include Windows.h)
  X As Long
  Y As Long
End Type

#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-deleteobject
  Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) 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/ja-jp/windows/win32/api/wingdi/nf-wingdi-lineto
  Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-movetoex
  Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) 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-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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
  Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
  Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC 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

Private IsDrag As Boolean ' マウスをドラッグ中か?
Private XPixelsPerInch As Long ' X方向の1インチのピクセル数
Private YPixelsPerInch As Long ' Y方向の1インチのピクセル数

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

Private Function GetX(ByVal X As Long) As Long ' X座標のポイントをピクセルに変換する
  GetX = X * XPixelsPerInch / 72
End Function

Private Function GetY(ByVal Y As Long) As Long ' Y座標のポイントをピクセルに変換する
  GetY = Y * XPixelsPerInch / 72
End Function

Private Sub CommandButton1_Click() ' 線を描く
  Repaint ' 描画のクリアー
End Sub

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

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim P As POINTAPI ' 位置(使いません)
  
  If Button <> 1 Then Exit Sub ' マウスの左ボタンでなければ終了
  IsDrag = True ' ドラッグ開始
  MoveToEx hDC, GetX(X), GetY(Y), P ' 位置を移動
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If IsDrag = False Then Exit Sub
  
#If Win64 Then
  Dim NewPen As LongPtr ' 新しいペン
  Dim OldPen As LongPtr ' 元のペン
#Else
  Dim NewPen As Long ' 新しいペン
  Dim OldPen As Long ' 元のペン
#End If

  NewPen = CreatePen(PS_SOLID, 10, VBA.ColorConstants.vbBlack) ' ペンの作成
  OldPen = SelectObject(hDC, NewPen) ' 新しいペンを選択
  
  LineTo hDC, GetX(X), GetY(Y) ' 線を描く
  
  SelectObject hDC, OldPen ' 元のペンに戻す
  DeleteObject NewPen ' ペンを削除
End Sub

Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  IsDrag = False ' ドラッグ終了
End Sub

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

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
このページの上