Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
'描画(GDI)関連
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDc As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
'図形(長方形/多角形)
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
Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hDc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function RoundRect Lib "gdi32.dll" (ByVal hDc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal width As Long, ByVal height As Long) As Long
Private Declare PtrSafe Function Polygon Lib "gdi32" (ByVal hDc As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As Long
'図形(円形関連)
Private Declare PtrSafe Function Pie 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, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare PtrSafe Function Chord 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, ByVal X4 As Long, ByVal Y4 As Long) As Long
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
'図形(線関連)
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDc As LongPtr, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function Polyline Lib "gdi32" (ByVal hDc As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare PtrSafe Function PolyBezier Lib "gdi32" (ByVal hDc As LongPtr, lppt As POINTAPI, ByVal cPoints As Long) As Long
'ﾍﾟﾝｽﾀｲﾙ
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 BS_SOLID = 0
Private Const BS_NULL = 1
Private Const BS_HOLLOW = BS_NULL
Private Const BS_HATCHED = 2
Private Const BS_PATTEREN = 3
'ﾊｯﾁﾝｸﾞｽﾀｲﾙ
Private Const HS_HORIZONTAL = 0 ' ------
Private Const HS_VERTICAL = 1 ' ||||||
Private Const HS_FDIAGONAL = 2 ' ＼＼＼
Private Const HS_BDIAGONAL = 3 ' //////
Private Const HS_CROSS = 4 ' ++++++
Private Const HS_DIAGCROSS = 5 ' xxxxxx
'長方形構造体
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'点座標構造体
Private Type POINTAPI
x As Long
y As Long
End Type
'論理ﾍﾟﾝ構造体
Private Type LOGPEN
lopnStyle As Long
lopnWidth As POINTAPI
lopnColor As Long
End Type
'論理ﾌﾞﾗｼ構造体
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As LongPtr
End Type
Private hWnd As LongPtr 'UserFormｳｨﾝﾄﾞｳﾊﾝﾄﾞﾙ
Private hDc As LongPtr 'UserFormｳｨﾝﾄﾞｳのﾃﾞﾊﾞｲｽｺﾝﾃｷｽﾄ
Private hPenDef As LongPtr '現在選択されているﾍﾟﾝ
Private hBrushDef As LongPtr '現在選択されているﾌﾞﾗｼ
Private cPens As Collection '作成した論理ﾍﾟﾝｺﾚｸｼｮﾝ
Private cBrushes As Collection '作成した論理ﾌﾞﾗｼｺﾚｸｼｮﾝ
'------------------------------------------------------------------
' UserForm起動時ｲﾍﾞﾝﾄ
'------------------------------------------------------------------
Private Sub UserForm_Initialize()
hWnd = FindWindow(vbNullString, Me.Caption) 'ｳｨﾝﾄﾞｳﾊﾝﾄﾞﾙ取得
hDc = GetDC(hWnd) 'DC取得
Set cPens = New Collection
Set cBrushes = New Collection
Me.BackColor = RGB(255, 255, 255)
'初期状態のDCのﾍﾟﾝとﾌﾞﾗｼを取得
Call GetDefaultPrnAndBrush
End Sub
Private Sub GetDefaultPrnAndBrush()
Dim hPenTmp As LongPtr
Dim hBrushTmp As LongPtr
hPenTmp = CreateLogicalPen(1, PS_NULL, 0)
hPenDef = SelectObject(hDc, hPenTmp)
hBrushTmp = CreateLogicalBrush(BS_NULL, 0, 0)
hBrushDef = SelectObject(hDc, hBrushTmp)
End Sub
Private Sub UserForm_Activate()
Me.Repaint 'UserForm起動時に描画するにはRepaintが必要
Call DrawShapes
End Sub
'------------------------------------------------------------------
' UserForm終了時ｲﾍﾞﾝﾄ
'------------------------------------------------------------------
Private Sub UserForm_Terminate()
Call DeleteAllObjects
Set cPens = Nothing
Set cBrushes = Nothing
Call ReleaseDC(hWnd, hDc)
End Sub
Sub DeleteAllObjects()
Dim hPen 'As LongPtr
Dim hBrush 'As LongPtr
'生成したﾍﾟﾝ削除
Call SelectObject(hDc, hPenDef)
For Each hPen In cPens
Call DeleteObject(hPen)
Next
'生成したﾌﾞﾗｼ削除
Call SelectObject(hDc, hBrushDef)
For Each hBrush In cBrushes
Call DeleteObject(hBrush)
Next
End Sub
'------------------------------------------------------------------
' 図形描画
'------------------------------------------------------------------
Private Sub DrawShapes()
Dim hPen1 As LongPtr
Dim hPen2 As LongPtr
Dim hPen3 As LongPtr
Dim hPen4 As LongPtr
Dim hPen5 As LongPtr
Dim hPen6 As LongPtr
Dim hBrush1 As LongPtr
Dim hBrush2 As LongPtr
Dim hBrush3 As LongPtr
Dim hBrush4 As LongPtr
Dim lpPoints1(4) As POINTAPI
Dim lpPoints2(3) As POINTAPI
Dim lpPoints3(2) As POINTAPI
'論理ﾍﾟﾝ作成
hPen1 = CreateLogicalPen(3, PS_SOLID, RGB(255, 0, 0))
hPen2 = CreateLogicalPen(1, PS_DASH, RGB(0, 255, 0))
hPen3 = CreateLogicalPen(1, PS_DASHDOTDOT, RGB(0, 0, 255))
hPen4 = CreateLogicalPen(1, PS_DOT, RGB(255, 128, 0))
hPen5 = CreateLogicalPen(1, PS_DASHDOT, RGB(255, 0, 255))
hPen6 = CreateLogicalPen(1, PS_NULL, RGB(0, 255, 128))
'論理ﾌﾞﾗｼ作成
hBrush1 = CreateLogicalBrush(BS_SOLID, RGB(255, 255, 128), 0)
hBrush2 = CreateLogicalBrush(BS_HATCHED, RGB(128, 255, 255), HS_CROSS)
hBrush3 = CreateLogicalBrush(BS_HATCHED, RGB(255, 128, 255), HS_DIAGCROSS)
hBrush4 = CreateLogicalBrush(BS_SOLID, RGB(128, 255, 128), HS_FDIAGONAL)
'折れ線頂点座標定義
lpPoints1(0).x = 20: lpPoints1(0).y = 80
lpPoints1(1).x = 40: lpPoints1(1).y = 90
lpPoints1(2).x = 60: lpPoints1(2).y = 80
lpPoints1(3).x = 80: lpPoints1(3).y = 90
lpPoints1(4).x = 100: lpPoints1(4).y = 80
'ﾍﾞｼﾞｪ曲線制御点座標定義
lpPoints2(0).x = 20: lpPoints2(0).y = 110
lpPoints2(1).x = 50: lpPoints2(1).y = 130
lpPoints2(2).x = 80: lpPoints2(2).y = 90
lpPoints2(3).x = 100: lpPoints2(3).y = 110
'多角形頂点座標定義
lpPoints3(0).x = 140: lpPoints3(0).y = 75
lpPoints3(1).x = 120: lpPoints3(1).y = 114
lpPoints3(2).x = 160: lpPoints3(2).y = 114
'直線/折れ線/ﾍﾞｼﾞｪ曲線
Call CreateLine(hPen1, 20, 20, 100, 20)
Call CreateLine(hPen2, 20, 40, 100, 40)
Call CreateLine(hPen3, 20, 60, 100, 60)
Call CreatePolyline(hPen4, lpPoints1)
Call CreateBezier(hPen5, lpPoints2)
'長方形/楕円/多角形/角が丸い長方形
Call CreateRectangle(hPen6, hBrush1, 120, 19, 160, 60)
Call CreateEllipse(hPen3, hBrush2, 175, 20, 215, 60)
Call CreatePolygon(hPen4, hBrush3, lpPoints3)
Call CreateRoundRectangle(hPen6, hBrush4, 175, 75, 215, 116, 15, 15)
End Sub
'------------------------------------------------------------------
' 論理ﾍﾟﾝ作成
' lThick ：ﾍﾟﾝ太さ
' lStyle ：ﾍﾟﾝｽﾀｲﾙ (定数値 PS_xxx)
' lColor ：ﾍﾟﾝｶﾗｰ
' 戻り値 ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
'------------------------------------------------------------------
Private Function CreateLogicalPen(lThick As Long, lStyle As Long, lColor As Long) As LongPtr
Dim lpPoint As POINTAPI
Dim lpLogPen As LOGPEN
Dim hPen As LongPtr
'POINTAPIのxでﾍﾟﾝ太さを定義 (※yは未使用)
lpPoint.x = lThick
'ﾍﾟﾝ設定
With lpLogPen
.lopnWidth = lpPoint 'ﾍﾟﾝ太さ
.lopnStyle = lStyle 'ﾍﾟﾝｽﾀｲﾙ
.lopnColor = lColor 'ﾍﾟﾝｶﾗｰ
End With
hPen = CreatePenIndirect(lpLogPen)
cPens.Add hPen
CreateLogicalPen = hPen
End Function
'------------------------------------------------------------------
' 論理ﾌﾞﾗｼ作成
' lStyle ：ﾌﾞﾗｼｽﾀｲﾙ (定数値 BS_xxx)
' lColor ：ﾌﾞﾗｼｶﾗｰ
' lHatch ：ﾊｯﾁﾝｸﾞｽﾀｲﾙ (定数値 HS_xxx)
' 戻り値 ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
'------------------------------------------------------------------
Private Function CreateLogicalBrush(lStyle As Long, lColor As Long, lHatch As Long) As LongPtr
Dim lpLogBrush As LOGBRUSH
Dim hBrush As LongPtr
'ﾌﾞﾗｼ設定
With lpLogBrush
.lbStyle = lStyle 'ﾌﾞﾗｼｽﾀｲﾙ
.lbColor = lColor 'ﾌﾞﾗｼｶﾗｰ
.lbHatch = lHatch 'ﾊｯﾁﾝｸﾞｽﾀｲﾙ (※lStyleがBS_HATCHED時に有効)
End With
'ﾌﾞﾗｼ作成
hBrush = CreateBrushIndirect(lpLogBrush)
cBrushes.Add hBrush
CreateLogicalBrush = hBrush
End Function
'------------------------------------------------------------------
' 直線作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' lX1 ：直線の始点X座標
' lY1 ：直線の始点Y座標
' lX2 ：直線の終点X座標
' lY2 ：直線の終点Y座標
'------------------------------------------------------------------
Private Function CreateLine(hPen As LongPtr, lX1 As Long, lY1 As Long, lX2 As Double, lY2 As Long)
Dim lpPoint As POINTAPI
Call SelectObject(hDc, hPen)
Call MoveToEx(hDc, lX1, lY1, lpPoint) '直線描画(始点定義)
Call LineTo(hDc, lX2, lY2) '直線描画(終点定義)
End Function
'------------------------------------------------------------------
' ﾍﾞｼﾞｪ曲線作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' lpPoins ：ﾍﾞｼﾞｪ曲線の制御点座標が格納された配列
'------------------------------------------------------------------
Private Function CreateBezier(hPen As LongPtr, lpPoins() As POINTAPI)
Call SelectObject(hDc, hPen)
Call PolyBezier(hDc, lpPoins(0), UBound(lpPoins) + 1)
End Function
'------------------------------------------------------------------
' 折れ線作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' lpPoins ：折れ線の頂点座標が格納された配列
'------------------------------------------------------------------
Private Function CreatePolyline(hPen As LongPtr, lpPoins() As POINTAPI)
Call SelectObject(hDc, hPen)
Call Polyline(hDc, lpPoins(0), UBound(lpPoins) + 1)
End Function
'------------------------------------------------------------------
' 多角形作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' hBrush ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
' lpPoins ：多角形の頂点座標が格納された配列
'------------------------------------------------------------------
Private Function CreatePolygon(hPen As LongPtr, hBrush As LongPtr, lpPoins() As POINTAPI)
Dim lpPoint As POINTAPI
Call SelectObject(hDc, hPen)
Call SelectObject(hDc, hBrush)
Call Polygon(hDc, lpPoins(0), UBound(lpPoins) + 1)
End Function
'------------------------------------------------------------------
' 長方形作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' hBrush ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
' lX1 ：長方形左上の頂点X座標
' lY1 ：長方形左上の頂点Y座標
' lX2 ：長方形右下の頂点X座標
' lY2 ：長方形右下の頂点Y座標
'------------------------------------------------------------------
Private Function CreateRectangle(hPen As LongPtr, hBrush As LongPtr, _
lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long)
Call SelectObject(hDc, hPen)
Call SelectObject(hDc, hBrush)
Call Rectangle(hDc, lX1, lY1, lX2, lY2)
End Function
'------------------------------------------------------------------
' 角の丸い長方形作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' hBrush ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
' lX1 ：長方形左上の頂点X座標
' lY1 ：長方形左上の頂点Y座標
' lX2 ：長方形右下の頂点X座標
' lY2 ：長方形右下の頂点Y座標
' lWidthR ：角の丸みの幅
' lHeightR：角の丸みの高さ
'------------------------------------------------------------------
Private Function CreateRoundRectangle(hPen As LongPtr, hBrush As LongPtr, _
lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long, _
lWidthR As Long, lHeightR As Long)
Call SelectObject(hDc, hPen)
Call SelectObject(hDc, hBrush)
Call RoundRect(hDc, lX1, lY1, lX2, lY2, lWidthR, lHeightR)
End Function
'------------------------------------------------------------------
' 楕円作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' hBrush ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
' lX1 ：楕円に外接する長方形左上の頂点X座標
' lY1 ：楕円に外接する長方形左上の頂点Y座標
' lX2 ：楕円に外接する長方形右下の頂点X座標
' lY2 ：楕円に外接する長方形右下の頂点Y座標
'------------------------------------------------------------------
Private Function CreateEllipse(hPen As LongPtr, hBrush As LongPtr, _
lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long)
Call SelectObject(hDc, hPen)
Call SelectObject(hDc, hBrush)
Call Ellipse(hDc, lX1, lY1, lX2, lY2) '楕円描画
End Function
'------------------------------------------------------------------
' パイ形作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' hBrush ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
' lX1 ：楕円に外接する長方形左上の頂点X座標
' lY1 ：楕円に外接する長方形左上の頂点Y座標
' lX2 ：楕円に外接する長方形右下の頂点X座標
' lY2 ：楕円に外接する長方形右下の頂点Y座標
' lX3 ：ﾊﾟｲ型の定義1の点X座標
' lY3 ：ﾊﾟｲ型の定義1の点Y座標
' lX4 ：ﾊﾟｲ型の定義2の点X座標
' lY4 ：ﾊﾟｲ型の定義2の点Y座標
'------------------------------------------------------------------
Private Function CreatePie(hPen As LongPtr, hBrush As LongPtr, _
lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long, _
lX3 As Long, lY3 As Long, lX4 As Long, lY4 As Long)
Call SelectObject(hDc, hPen)
Call SelectObject(hDc, hBrush)
Call Pie(hDc, lX1, lY1, lX2, lY2, lX3, lY3, lX4, lY4)
End Function
'------------------------------------------------------------------
' 弦形作成
' hPen ：論理ﾍﾟﾝﾊﾝﾄﾞﾙ
' hBrush ：論理ﾌﾞﾗｼﾊﾝﾄﾞﾙ
' lX1 ：楕円に外接する長方形左上の頂点X座標
' lY1 ：楕円に外接する長方形左上の頂点Y座標
' lX2 ：楕円に外接する長方形右下の頂点X座標
' lY2 ：楕円に外接する長方形右下の頂点Y座標
' lX3 ：弦形の定義1の点X座標
' lY3 ：弦型の定義1の点Y座標
' lX4 ：弦型の定義2の点X座標
' lY4 ：弦型の定義2の点Y座標
'------------------------------------------------------------------
Private Function CreateChord(hPen As LongPtr, hBrush As LongPtr, _
lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long, _
lX3 As Long, lY3 As Long, lX4 As Long, lY4 As Long)
Call SelectObject(hDc, hPen)
Call SelectObject(hDc, hBrush)
Call Chord(hDc, lX1, lY1, lX2, lY2, lX3, lY3, lX4, lY4)
End Function
WindowsAPIを使うことで上画像のようにUserForm上に直線や四角形、楕円や多角形などの基本的な図形を描画することができます。このとき描画する図形それぞれに対して線種や線幅、色、塗りつぶし、ハッチングの種類、ビットマップパターンなどの細かな設定を行うことが可能です。
https://liclog.net/vba-windows-api-index/