AutoCAD VBAによる矩形内切取複写


AutoCAD VBAで矩形内切取複写をつくってみました。
ソースは下のようになっています。
ヘルプを見ながらつくった3つ目のプログラムです。
確実にするためにundo mをダブルにしました。2003.06.17

Sub cutc()

    '矩形内切取複写プログラム
    'cutc.dvb
    '四角で囲んだ部分の矩形内を切り取り複写する。
    'このプログラムcutc.dvbをサポートパスの通したフォルダ
    'たとえばsupportフォルダにいれ、以下のツールバーのボタンを
    'つくります。
    '^C^C-vbarun;"cutc.dvb!Module1.cutc";
    'そして、そのボタンを押して矩形を描くと囲った部分を切り取り複写します。

    Dim returnPnt As Variant
        
    ' Return a point using a prompt
    returnPnt = ThisDrawing.Utility.GetPoint(, "Click a point: ")
    
    xx0 = returnPnt(0)
    yy0 = returnPnt(1)
    
    ' This example provides a base point and prompts the user to
    ' input the second point to make a rectangle.
    Dim basePnt(0 To 2) As Double
    
    basePnt(0) = xx0: basePnt(1) = yy0: basePnt(2) = 0#
        
    ' Prompt the user to pick second point and returns the point
    returnPnt = ThisDrawing.Utility.GetCorner(basePnt, "Click Other corner: ")
        
    X = returnPnt(0) - basePnt(0)
    Y = returnPnt(1) - basePnt(1)
    
    ThisDrawing.SendCommand "undo m "
    ThisDrawing.SendCommand "undo m ucs w ucs o none " & xx0 & "," & yy0 & " rectang none 0,0 none " & X & "," & Y & " select l  "
    
    If X > 0 And Y > 0 Then
        For i = 1 To 10
            X1 = -0.2: Y1 = -0.2: X2 = X + 0.2: Y2 = -0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            X1 = -0.2: Y1 = Y + 0.2: X2 = X + 0.2: Y2 = Y + 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = -0.2: X1 = -0.2: Y2 = Y + 0.2: X2 = -0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = -0.2: X1 = X + 0.2: Y2 = Y + 0.2: X2 = X + 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        
     
    End If
    
    If X < 0 And Y > 0 Then
        For i = 1 To 10
            X1 = -0.2: Y1 = -0.2: X2 = X + 0.2: Y2 = -0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            X1 = -0.2: Y1 = Y + 0.2: X2 = X + 0.2: Y2 = Y + 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = -0.2: X1 = 0.2: Y2 = Y + 0.2: X2 = 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = -0.2: X1 = X - 0.2: Y2 = Y + 0.2: X2 = X - 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
    
    End If
    
    If X > 0 And Y < 0 Then
        For i = 1 To 10
            X1 = -0.2: Y1 = 0.2: X2 = X + 0.2: Y2 = 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            X1 = -0.2: Y1 = Y - 0.2: X2 = X + 0.2: Y2 = Y - 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = 0.2: X1 = -0.2: Y2 = Y - 0.2: X2 = -0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = 0.2: X1 = X + 0.2: Y2 = Y - 0.2: X2 = X + 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        
    End If
     
    If X < 0 And Y < 0 Then
        For i = 1 To 10
            X1 = 0.2: Y1 = 0.2: X2 = X - 0.2: Y2 = 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            X1 = 0.2: Y1 = Y - 0.2: X2 = X - 0.2: Y2 = Y - 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = 0.2: X1 = 0.2: Y2 = Y - 0.2: X2 = 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
        For i = 1 To 10
            Y1 = 0.2: X1 = X - 0.2: Y2 = Y - 0.2: X2 = X - 0.2
            ThisDrawing.SendCommand "trim _P  _F _none " & X1 & "," & Y1 & " _none " & X2 & "," & Y2 & "  " & Chr$(13)
        Next i
    
    End If
    
    ThisDrawing.SendCommand "select w _none 0,0 _none " & X & "," & Y & Chr$(13) & Chr$(13)
    ThisDrawing.SendCommand "copybase 0,0 P  undo b" & Chr$(13)
    ThisDrawing.SendCommand "pasteclip" & Chr$(13) & Chr$(13)

End Sub


ここからダウンロードしてください。
矩形内切取複写cutcdvb.lzh (約9KB)



Back Home Forward