Admin Memo2
アイソメ
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
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)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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描画
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
'参考: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 |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 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 |