Admin Memo2

1. アイソメ
2. 断面指示更新(Pure Sketch)
3. UserForm描画

アイソメ

Option Explicit

'Isometric Component
Const SIGHT_VECTOR_COMPONENT    As Double = -0.577350318431854
Const UP_VECTOR_COMPONENT1      As Double = -0.40824830532074
Const UP_VECTOR_COMPONENT2      As Double = 0.816496610641479

Sub Sample()


    Dim oWin As Window
    Dim oViewer As Viewer3D
    Dim oViewPt3D 'As Viewpoint3D
    
    
    Set oWin = CATIA.ActiveWindow
    Set oViewer = oWin.ActiveViewer
    Set oViewPt3D = oViewer.Viewpoint3D
    
    Dim oVec1(2)
    Dim oVec2(2)
    Dim origin(2)
    
'    Call oViewPt3D.GetSightDirection(oVec1)
'    Call oViewPt3D.GetUpDirection(oVec2)
    Call oViewPt3D.GetOrigin(origin)
    

    oVec1(0) = SIGHT_VECTOR_COMPONENT
    oVec1(1) = SIGHT_VECTOR_COMPONENT
    oVec1(2) = SIGHT_VECTOR_COMPONENT
    
    oVec2(0) = UP_VECTOR_COMPONENT1
    oVec2(1) = UP_VECTOR_COMPONENT1
    oVec2(2) = UP_VECTOR_COMPONENT2
    
    
    Call oViewPt3D.PutSightDirection(oVec1)
    Call oViewPt3D.PutUpDirection(oVec2)
    Call oViewPt3D.PutOrigin(origin)
    Call oViewer.Update
    'Call CATIA.StartCommand("選択")

End Sub

Option Explicit

'Isometric Component

Const SIGHT_VECTOR_COMPONENT As Double = -0.577350318431854

Const UP_VECTOR_COMPONENT1 As Double = -0.40824830532074

Const UP_VECTOR_COMPONENT2 As Double = 0.816496610641479

Sub Sample()

Dim oWin As Window

Dim oViewer As Viewer3D

Dim oViewPt3D 'As Viewpoint3D

Set oWin = CATIA.ActiveWindow

Set oViewer = oWin.ActiveViewer

Set oViewPt3D = oViewer.Viewpoint3D

Dim oVec1(2)

Dim oVec2(2)

Dim origin(2)

' Call oViewPt3D.GetSightDirection(oVec1)

' Call oViewPt3D.GetUpDirection(oVec2)

Call oViewPt3D.GetOrigin(origin)

oVec1(0) = SIGHT_VECTOR_COMPONENT

oVec1(1) = SIGHT_VECTOR_COMPONENT

oVec1(2) = SIGHT_VECTOR_COMPONENT

oVec2(0) = UP_VECTOR_COMPONENT1

oVec2(1) = UP_VECTOR_COMPONENT1

oVec2(2) = UP_VECTOR_COMPONENT2

Call oViewPt3D.PutSightDirection(oVec1)

Call oViewPt3D.PutUpDirection(oVec2)

Call oViewPt3D.PutOrigin(origin)

Call oViewer.Update

'Call CATIA.StartCommand("選択")

End Sub

断面指示更新(Pure Sketch)

Sub CATMain()
 

'---- ｵﾌﾞｼﾞｪｸﾄのﾚｿﾞﾘｭｰｼｮﾝ ｽｸﾘﾌﾟﾄの開始: ﾘｽﾄ.1
 
Dim drawingDocument1 As DrawingDocument
Set drawingDocument1 = CATIA.ActiveDocument

Dim parameters1 As Parameters
Set parameters1 = drawingDocument1.Parameters

Dim listParameter1 As ListParameter
Set listParameter1 = parameters1.Item("ﾘｽﾄ.1")

'---- ﾚｿﾞﾘｭｰｼｮﾝ ｽｸﾘﾌﾟﾄの終了


'---- ｵﾌﾞｼﾞｪｸﾄのﾚｿﾞﾘｭｰｼｮﾝ ｽｸﾘﾌﾟﾄの開始: 正面図
 
Dim drawingSheets1 As DrawingSheets
Set drawingSheets1 = drawingDocument1.Sheets

Dim drawingSheet1 As DrawingSheet
Set drawingSheet1 = drawingSheets1.Item("ｼｰﾄ.1")

Dim drawingViews1 As DrawingViews
Set drawingViews1 = drawingSheet1.Views

Dim drawingView1 As DrawingView
Set drawingView1 = drawingViews1.Item("正面図")

Dim drawingView2 As DrawingView
Set drawingView2 = drawingViews1.Item("断面図 A-A")
'---- ﾚｿﾞﾘｭｰｼｮﾝ ｽｸﾘﾌﾟﾄの終了
 
    Dim oLin2D As Line2D
    Dim oPt2D1 As Point2D
    Dim oPt2D2 As Point2D
    Dim oTxt1 As DrawingText
    Dim oTxt2 As DrawingText
    
    Dim dCoord1X As Double
    Dim dCoord1Y As Double
    Dim dCoord2X As Double
    Dim dCoord2Y As Double
    Dim vVec
    Dim oPureSketch As Sketch
    Dim oFac2D As Factory2D
     
     
    '切断線の始点終点座標
    dCoord1X = -50
    dCoord1Y = 10
    dCoord2X = 50
    dCoord2Y = 10
    
    '単位ﾍﾞｸﾄﾙ取得
    vVec = GetUnitVector(dCoord1X, dCoord1Y, dCoord1Y, dCoord2Y)
        
    'ﾘｽﾄ経由でPureSketch内にある切断線形状を直接取得する
    Set oLin2D = listParameter1.ValueList.Item(1)
    Set oPt2D1 = listParameter1.ValueList.Item(2)
    Set oPt2D2 = listParameter1.ValueList.Item(3)
    Set oPureSketch = oLin2D.Parent.Parent

    'PureSketch内にある切断線形状をﾜｰｸﾍﾞﾝﾁを切り替えずに移動する
    Call oPt2D1.SetData(dCoord1X, dCoord1Y)
    Call oPt2D2.SetData(dCoord2X, dCoord2Y)
    oLin2D.StartPoint = oPt2D1
    oLin2D.EndPoint = oPt2D2
    Call oLin2D.SetData(dCoord1X, dCoord1Y, vVec(0), vVec(1))

    'Evaluateしないと矢印 & 断面記号が更新されない
    oPureSketch.Evaluate
    
    'Updateしないと切断線が更新されない
    Call drawingView1.GenerativeBehavior.ForceUpdate
    
    'Updateしないと変更後の断面にならない
    Call drawingView2.GenerativeBehavior.ForceUpdate

End Sub

'2点座標から単位ﾍﾞｸﾄﾙ成分を取得する
Private Function GetUnitVector(dX1 As Double, dY1 As Double, _
                               dX2 As Double, dY2 As Double) As Variant
                               
    Dim vUnit(1)
    Dim dX As Double
    Dim dY As Double
    Dim dSize As Double
            
    dX = dX2 - dX1
    dY = dY2 - dY1
                               
    dSize = Sqr(dX * dX + dY * dY)
    
    vUnit(0) = dX / dSize
    vUnit(1) = dY / dSize

    GetUnitVector = vUnit
    
End Function

100

101

102

103

Sub CATMain()

'---- ｵﾌﾞｼﾞｪｸﾄのﾚｿﾞﾘｭｰｼｮﾝｽｸﾘﾌﾟﾄの開始: ﾘｽﾄ.1

Dim drawingDocument1 As DrawingDocument

Set drawingDocument1 = CATIA.ActiveDocument

Dim parameters1 As Parameters

Set parameters1 = drawingDocument1.Parameters

Dim listParameter1 As ListParameter

Set listParameter1 = parameters1.Item("ﾘｽﾄ.1")

'---- ﾚｿﾞﾘｭｰｼｮﾝｽｸﾘﾌﾟﾄの終了

'---- ｵﾌﾞｼﾞｪｸﾄのﾚｿﾞﾘｭｰｼｮﾝｽｸﾘﾌﾟﾄの開始: 正面図

Dim drawingSheets1 As DrawingSheets

Set drawingSheets1 = drawingDocument1.Sheets

Dim drawingSheet1 As DrawingSheet

Set drawingSheet1 = drawingSheets1.Item("ｼｰﾄ.1")

Dim drawingViews1 As DrawingViews

Set drawingViews1 = drawingSheet1.Views

Dim drawingView1 As DrawingView

Set drawingView1 = drawingViews1.Item("正面図")

Dim drawingView2 As DrawingView

Set drawingView2 = drawingViews1.Item("断面図 A-A")

'---- ﾚｿﾞﾘｭｰｼｮﾝｽｸﾘﾌﾟﾄの終了

Dim oLin2D As Line2D

Dim oPt2D1 As Point2D

Dim oPt2D2 As Point2D

Dim oTxt1 As DrawingText

Dim oTxt2 As DrawingText

Dim dCoord1X As Double

Dim dCoord1Y As Double

Dim dCoord2X As Double

Dim dCoord2Y As Double

Dim vVec

Dim oPureSketch As Sketch

Dim oFac2D As Factory2D

'切断線の始点終点座標

dCoord1X = -50

dCoord1Y = 10

dCoord2X = 50

dCoord2Y = 10

'単位ﾍﾞｸﾄﾙ取得

vVec = GetUnitVector(dCoord1X, dCoord1Y, dCoord1Y, dCoord2Y)

'ﾘｽﾄ経由でPureSketch内にある切断線形状を直接取得する

Set oLin2D = listParameter1.ValueList.Item(1)

Set oPt2D1 = listParameter1.ValueList.Item(2)

Set oPt2D2 = listParameter1.ValueList.Item(3)

Set oPureSketch = oLin2D.Parent.Parent

'PureSketch内にある切断線形状をﾜｰｸﾍﾞﾝﾁを切り替えずに移動する

Call oPt2D1.SetData(dCoord1X, dCoord1Y)

Call oPt2D2.SetData(dCoord2X, dCoord2Y)

oLin2D.StartPoint = oPt2D1

oLin2D.EndPoint = oPt2D2

Call oLin2D.SetData(dCoord1X, dCoord1Y, vVec(0), vVec(1))

'Evaluateしないと矢印 & 断面記号が更新されない

oPureSketch.Evaluate

'Updateしないと切断線が更新されない

Call drawingView1.GenerativeBehavior.ForceUpdate

'Updateしないと変更後の断面にならない

Call drawingView2.GenerativeBehavior.ForceUpdate

End Sub

'2点座標から単位ﾍﾞｸﾄﾙ成分を取得する

Private Function GetUnitVector(dX1 As Double, dY1 As Double, _

dX2 As Double, dY2 As Double) As Variant

Dim vUnit(1)

Dim dX As Double

Dim dY As Double

Dim dSize As Double

dX = dX2 - dX1

dY = dY2 - dY1

dSize = Sqr(dX * dX + dY * dY)

vUnit(0) = dX / dSize

vUnit(1) = dY / dSize

GetUnitVector = vUnit

End Function

UserForm描画

'参考：http://shadowslasheizan.blog114.fc2.com/blog-entry-160.html


Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hgdiobj As LongPtr) As Long
Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Declare PtrSafe Function CreatePenIndirect Lib "gdi32.dll" (lplgpl As LOGPEN) As Long
Declare PtrSafe Function CreateBrushIndirect Lib "gdi32.dll" (lplb As LOGBRUSH) As Long
Declare PtrSafe Function LineTo Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
Declare PtrSafe Function MoveToEx Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long

Declare PtrSafe Function Rectangle Lib "gdi32" _
(ByVal hdc As LongPtr, _
ByVal Left As Long, _
ByVal Top As Long, _
ByVal Right As Long, _
ByVal Bottom As Long) As Long

Declare PtrSafe Function Ellipse Lib "gdi32" _
(ByVal hdc As LongPtr, _
ByVal nLeftRect As Long, _
ByVal nTopRect As Long, _
ByVal nRightRect As Long, _
ByVal nBottomRect As Long) As Long

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

'■構造体の宣言

Type POINTAPI
    X As Long
    Y As Long
End Type

Type LOGPEN
    lopnStyle As Long
    lopnWidth As POINTAPI
    lopnColor As Long
End Type

Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

'■定数の宣言

Public Const PS_SOLID As Long = 0
Public Const PS_DASH As Long = 1
Public Const PS_DOT As Long = 2
Public Const PS_DASHDOT As Long = 3
Public Const PS_DASHDOTDOT As Long = 4
Public Const PS_NULL As Long = 5
Public Const PS_INSIDEFRAME As Long = 6

Public Const BS_SOLID As Long = 0
Public Const BS_HOLLOW As Long = 1
Public Const BS_HATCHED As Long = 2
Public Const BS_PATTEREN As Long = 3
Public Const BS_DIBPATTERN As Long = 5

Public Const HS_HORIZONTAL As Long = 0
Public Const HS_VERTICAL As Long = 1
Public Const HS_FDIAGONAL As Long = 2
Public Const HS_BDIAGONAL As Long = 3
Public Const HS_CROSS As Long = 4
Public Const HS_DIAGCROSS As Long = 5

'■Public変数の宣言
Public hwnd As LongPtr
Public hdc As LongPtr
Public cPenObj As New Collection
Public cBrushObj As New Collection
Public dPen As Long
Public dBrush As Long

Sub main()

    UserForm1.Show vbModeless

End Sub

'参考：http://shadowslasheizan.blog114.fc2.com/blog-entry-160.html

Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" _

(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As Long

Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long

Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hgdiobj As LongPtr) As Long

Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Declare PtrSafe Function CreatePenIndirect Lib "gdi32.dll" (lplgpl As LOGPEN) As Long

Declare PtrSafe Function CreateBrushIndirect Lib "gdi32.dll" (lplb As LOGBRUSH) As Long

Declare PtrSafe Function LineTo Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long

Declare PtrSafe Function MoveToEx Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long

Declare PtrSafe Function Rectangle Lib "gdi32" _

(ByVal hdc As LongPtr, _

ByVal Left As Long, _

ByVal Top As Long, _

ByVal Right As Long, _

ByVal Bottom As Long) As Long

Declare PtrSafe Function Ellipse Lib "gdi32" _

(ByVal hdc As LongPtr, _

ByVal nLeftRect As Long, _

ByVal nTopRect As Long, _

ByVal nRightRect As Long, _

ByVal nBottomRect As Long) As Long

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

'■構造体の宣言

Type POINTAPI

X As Long

Y As Long

End Type

Type LOGPEN

lopnStyle As Long

lopnWidth As POINTAPI

lopnColor As Long

End Type

Type LOGBRUSH

lbStyle As Long

lbColor As Long

lbHatch As Long

End Type

'■定数の宣言

Public Const PS_SOLID As Long = 0

Public Const PS_DASH As Long = 1

Public Const PS_DOT As Long = 2

Public Const PS_DASHDOT As Long = 3

Public Const PS_DASHDOTDOT As Long = 4

Public Const PS_NULL As Long = 5

Public Const PS_INSIDEFRAME As Long = 6

Public Const BS_SOLID As Long = 0

Public Const BS_HOLLOW As Long = 1

Public Const BS_HATCHED As Long = 2

Public Const BS_PATTEREN As Long = 3

Public Const BS_DIBPATTERN As Long = 5

Public Const HS_HORIZONTAL As Long = 0

Public Const HS_VERTICAL As Long = 1

Public Const HS_FDIAGONAL As Long = 2

Public Const HS_BDIAGONAL As Long = 3

Public Const HS_CROSS As Long = 4

Public Const HS_DIAGCROSS As Long = 5

'■Public変数の宣言

Public hwnd As LongPtr

Public hdc As LongPtr

Public cPenObj As New Collection

Public cBrushObj As New Collection

Public dPen As Long

Public dBrush As Long

Sub main()

UserForm1.Show vbModeless

End Sub

Private Sub UserForm_Terminate()

    DeleteAll

End Sub


Function p_create(p_pixel As Long, p_style As Long, p_color As Long) As LongPtr

'ペンオブジェクトを生成する
    Dim p As POINTAPI
    Dim lp As LOGPEN
    Dim np As LongPtr
    
    p.X = p_pixel
    
    With lp
        .lopnStyle = p_style
        .lopnWidth = p
        .lopnColor = p_color
    End With
    
    np = CreatePenIndirect(lp)
    cPenObj.Add np
    
    p_create = np
    
End Function

Function b_create(b_style As Long, b_color As Long, b_hatch As Long) As LongPtr
'ブラシオブジェクトを生成する
    Dim lb As LOGBRUSH
    Dim nb As LongPtr

    With lb
        .lbStyle = b_style
        .lbColor = b_color
        .lbHatch = b_hatch
    End With

    nb = CreateBrushIndirect(lb)
    cBrushObj.Add nb

    b_create = nb

End Function


Private Sub TextBox1_Change()

    Call CreateLine

End Sub
Private Sub TextBox2_Change()

    Call CreateLine

End Sub
Private Sub TextBox3_Change()

    Call CreateLine

End Sub
Private Sub TextBox4_Change()

    Call CreateLine

End Sub

Private Function CreateLine()

    Dim dX1 As Double
    Dim dY1 As Double
    Dim dX2 As Double
    Dim dY2 As Double
    
    On Error Resume Next
        dX1 = CDbl(Me.TextBox1.Value) + PointToPixcel(Me.Frame1.Left)
        dY1 = CDbl(Me.TextBox2.Value) + PointToPixcel(Me.Frame1.Top)
        dX2 = CDbl(Me.TextBox3.Value) + PointToPixcel(Me.Frame1.Left)
        dY2 = CDbl(Me.TextBox4.Value) + PointToPixcel(Me.Frame1.Top)
        If Err.Number <> 0 Then Exit Function
    On Error GoTo 0
    
    If dX1 < PointToPixcel(Me.Frame1.Left) Then dX1 = PointToPixcel(Me.Frame1.Left)
    If dX2 < PointToPixcel(Me.Frame1.Left) Then dX2 = PointToPixcel(Me.Frame1.Left)
    If dX1 > PointToPixcel(Me.Frame1.Left + Me.Frame1.Width) Then dX1 = PointToPixcel(Me.Frame1.Left + Me.Frame1.Width)
    If dX2 > PointToPixcel(Me.Frame1.Left + Me.Frame1.Width) Then dX2 = PointToPixcel(Me.Frame1.Left + Me.Frame1.Width)

    If dY1 < PointToPixcel(Me.Frame1.Top) Then dY1 = Me.Frame1.Top + MARGIN
    If dY2 < PointToPixcel(Me.Frame1.Top) Then dY2 = Me.Frame1.Top + MARGIN
    If dY1 > PointToPixcel(Me.Frame1.Top + Me.Frame1.Height) Then dY1 = PointToPixcel(Me.Frame1.Top + Me.Frame1.Height)
    If dY2 > PointToPixcel(Me.Frame1.Top + Me.Frame1.Height) Then dY2 = PointToPixcel(Me.Frame1.Top + Me.Frame1.Height)

    Me.Repaint
    Call DeleteAll

    'ウィンドウハンドルを取得する
    hwnd = FindWindow(vbNullString, Me.Caption)
    hdc = GetDC(hwnd)
    
    Dim pen As LongPtr
    Dim brush As LongPtr
    Dim lpPoint As POINTAPI
'
    pen = p_create(1, PS_SOLID, RGB(255, 0, 0)) '①
    brush = b_create(BS_SOLID, RGB(255, 255, 0), 0) '②
    dPen = SelectObject(hdc, pen) '③
    dBrush = SelectObject(hdc, brush) '④
'    Rectangle hdc, 10, 10, 60, 60 '⑤
'    Ellipse hdc, 70, 10, 120, 60 '⑥
    MoveToEx hdc, dX1, dY1, lpPoint    '⑦
    LineTo hdc, dX2, dY2 '⑧
    
End Function

Private Sub DeleteAll()

    Dim v As Variant

    Call SelectObject(hdc, dPen)
    For Each v In cPenObj
        DeleteObject v
    Next

    Call ReleaseDC(hwnd, hdc)

End Sub

Private Function PointToPixcel(dPt As Double) As Double

    Const DPI As Double = 96
    Dim dPx As Double

    dPx = dPt / 72 * DPI
    
    PointToPixcel = dPx

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

Private Sub UserForm_Terminate()

DeleteAll

End Sub

Function p_create(p_pixel As Long, p_style As Long, p_color As Long) As LongPtr

'ペンオブジェクトを生成する

Dim p As POINTAPI

Dim lp As LOGPEN

Dim np As LongPtr

p.X = p_pixel

With lp

.lopnStyle = p_style

.lopnWidth = p

.lopnColor = p_color

End With

np = CreatePenIndirect(lp)

cPenObj.Add np

p_create = np

End Function

Function b_create(b_style As Long, b_color As Long, b_hatch As Long) As LongPtr

'ブラシオブジェクトを生成する

Dim lb As LOGBRUSH

Dim nb As LongPtr

With lb

.lbStyle = b_style

.lbColor = b_color

.lbHatch = b_hatch

End With

nb = CreateBrushIndirect(lb)

cBrushObj.Add nb

b_create = nb

End Function

Private Sub TextBox1_Change()

Call CreateLine

End Sub

Private Sub TextBox2_Change()

Call CreateLine

End Sub

Private Sub TextBox3_Change()

Call CreateLine

End Sub

Private Sub TextBox4_Change()

Call CreateLine

End Sub

Private Function CreateLine()

Dim dX1 As Double

Dim dY1 As Double

Dim dX2 As Double

Dim dY2 As Double

On Error Resume Next

dX1 = CDbl(Me.TextBox1.Value) + PointToPixcel(Me.Frame1.Left)

dY1 = CDbl(Me.TextBox2.Value) + PointToPixcel(Me.Frame1.Top)

dX2 = CDbl(Me.TextBox3.Value) + PointToPixcel(Me.Frame1.Left)

dY2 = CDbl(Me.TextBox4.Value) + PointToPixcel(Me.Frame1.Top)

If Err.Number <> 0 Then Exit Function

On Error GoTo 0

If dX1 < PointToPixcel(Me.Frame1.Left) Then dX1 = PointToPixcel(Me.Frame1.Left)

If dX2 < PointToPixcel(Me.Frame1.Left) Then dX2 = PointToPixcel(Me.Frame1.Left)

If dX1 > PointToPixcel(Me.Frame1.Left + Me.Frame1.Width) Then dX1 = PointToPixcel(Me.Frame1.Left + Me.Frame1.Width)

If dX2 > PointToPixcel(Me.Frame1.Left + Me.Frame1.Width) Then dX2 = PointToPixcel(Me.Frame1.Left + Me.Frame1.Width)

If dY1 < PointToPixcel(Me.Frame1.Top) Then dY1 = Me.Frame1.Top + MARGIN

If dY2 < PointToPixcel(Me.Frame1.Top) Then dY2 = Me.Frame1.Top + MARGIN

If dY1 > PointToPixcel(Me.Frame1.Top + Me.Frame1.Height) Then dY1 = PointToPixcel(Me.Frame1.Top + Me.Frame1.Height)

If dY2 > PointToPixcel(Me.Frame1.Top + Me.Frame1.Height) Then dY2 = PointToPixcel(Me.Frame1.Top + Me.Frame1.Height)

Me.Repaint

Call DeleteAll

'ウィンドウハンドルを取得する

hwnd = FindWindow(vbNullString, Me.Caption)

hdc = GetDC(hwnd)

Dim pen As LongPtr

Dim brush As LongPtr

Dim lpPoint As POINTAPI

pen = p_create(1, PS_SOLID, RGB(255, 0, 0)) '①

brush = b_create(BS_SOLID, RGB(255, 255, 0), 0) '②

dPen = SelectObject(hdc, pen) '③

dBrush = SelectObject(hdc, brush) '④

' Rectangle hdc, 10, 10, 60, 60 '⑤

' Ellipse hdc, 70, 10, 120, 60 '⑥

MoveToEx hdc, dX1, dY1, lpPoint '⑦

LineTo hdc, dX2, dY2 '⑧

End Function

Private Sub DeleteAll()

Dim v As Variant

Call SelectObject(hdc, dPen)

For Each v In cPenObj

DeleteObject v

Call ReleaseDC(hwnd, hdc)

End Sub

Private Function PointToPixcel(dPt As Double) As Double

Const DPI As Double = 96

Dim dPx As Double

dPx = dPt / 72 * DPI

PointToPixcel = dPx

End Function

2023年3月26日2023年5月25日@LiCLOG

Posted by Lic