2007仿2012copy

zlg258369 · 发表于 2011-12-10 12:13:34

本帖最后由 zlg258369 于 2011-12-10 13:03 编辑

cad2007用的仿2012版的copy

还有我的先选择后执行为什么不好用呢
Dim res As PromptSelectionResult
 Dim sSet As SelectionSet
 Dim opt As New PromptSelectionOptions
 res = ed.SelectImplied()
 If res.Status = PromptStatus.OK Then
 sSet = res.Value
 ids = sSet.GetObjectIds()
 Else
 ' 选择集交互操作
 opt.MessageForAdding = "请选择对象:"
 opt.AllowDuplicates = True
 res = ed.GetSelection(opt)
 If res.Status <> PromptStatus.OK Then Return
 sSet = res.Value
 ids = sSet.GetObjectIds()
 End If

zlg258369 · 发表于 2011-12-10 13:06:01

本帖最后由 zlg258369 于 2011-12-10 13:10 编辑

代码在这里

Public Class Jig_CCopy
' 从DrawJig类继承.
Inherits DrawJig
' 声明全局变量.
Dim sourcePt, targetPt, curPt As Point3d
Dim keyword As String
Dim i, k, few As Integer
Dim entCopy(,), entCopy1(), oldEnt() As Entity, ids As ObjectId()
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
<CommandMethod("CCopy")> Sub testCCopy()
keyword = "C"
Dim res As PromptSelectionResult
Dim sSet As SelectionSet
Dim opt As New PromptSelectionOptions
res = ed.SelectImplied()
If res.Status = PromptStatus.OK Then
sSet = res.Value
ids = sSet.GetObjectIds()
Else
' 选择集交互操作
opt.MessageForAdding = "请选择对象:"
opt.AllowDuplicates = True
res = ed.GetSelection(opt)
If res.Status <> PromptStatus.OK Then Return
sSet = res.Value
ids = sSet.GetObjectIds()
End If
' 得到基点
Dim optPoint As New PromptPointOptions(vbCrLf & "请输入基点:")
optPoint.AllowNone = True
Dim resPoint As PromptPointResult = ed.GetPoint(optPoint)
If resPoint.Status <> PromptStatus.OK Then Return
sourcePt = resPoint.Value
ReDim entCopy1(ids.Length - 1)
ReDim oldEnt(ids.Length - 1)
'获取对象
Using trans As Transaction = db.TransactionManager.StartTransaction()
For i = 0 To ids.Length - 1
oldEnt(i) = trans.GetObject(ids(i), OpenMode.ForWrite)
Next
trans.Commit()
End Using
Dim lop As Boolean = True
'循环
Do While lop = True
For i = 0 To ids.Length - 1
' 将源对象设置为高亮
oldEnt(i).Highlight()
' 复制
entCopy1(i) = oldEnt(i).Clone()
Next
' 设置目标点和拖拽临时点
targetPt = sourcePt
curPt = targetPt
' 开始拖拽.
Dim jigRes As PromptResult = ed.Drag(Me)
If jigRes.Status = PromptStatus.OK Then
For i = 0 To ids.Length - 1
AppendEntity(entCopy1(i))
Next
ElseIf keyword = "A" Then
targetPt = sourcePt
curPt = targetPt
' 开始拖拽.
jigRes = ed.Drag(Me)
If jigRes.Status = PromptStatus.OK Then
For k = 0 To few - 1
For i = 0 To ids.Length - 1
AppendEntity(entCopy(k, i))
Next
Next
' 取消源对象的高亮状态.
For i = 0 To ids.Length - 1
oldEnt(i).Unhighlight()
Next
'结束循环
lop = False
ElseIf keyword = "F" Then
targetPt = sourcePt
curPt = targetPt
' 开始拖拽.
jigRes = ed.Drag(Me)
If jigRes.Status = PromptStatus.OK Then
For k = 0 To few - 1
For i = 0 To ids.Length - 1
AppendEntity(entCopy(k, i))
Next
Next
' 取消源对象的高亮状态.
For i = 0 To ids.Length - 1
oldEnt(i).Unhighlight()
Next
lop = False
Else
lop = False
' 取消源对象的高亮状态.
For i = 0 To ids.Length - 1
oldEnt(i).Unhighlight()
Next
End If
Else
lop = False
' 取消源对象的高亮状态.
For i = 0 To ids.Length - 1
oldEnt(i).Unhighlight()
Next
End If
Else
lop = False
' 取消源对象的高亮状态.
For i = 0 To ids.Length - 1
oldEnt(i).Unhighlight()
Next
End If
Loop
End Sub
' Sampler函数用于检测用户的输入.
Protected Overrides Function Sampler(ByVal prompts As JigPrompts) As SamplerStatus
If keyword = "C" Then
Dim optJig As New JigPromptPointOptions(vbCrLf & "请指定第二点[阵列(A)]:")
' 设置拖拽光标类型.
optJig.Cursor = CursorType.RubberBand
' 设置拖动光标基点.
optJig.BasePoint = sourcePt
optJig.UseBasePoint = True
'为optJig添加关键字
optJig.Keywords.Add("A", "A", "A", False, True)
'optJig.Keywords.Add("C", "C", "C", False, True)
''默认关键字
'optJig.Keywords.Default = "C"
' 用AcquirePoint函数得到用户输入的点.
Dim resJig As PromptPointResult = prompts.AcquirePoint(optJig)
targetPt = resJig.Value
' 如果用户拖拽，则用矩阵变换的方法移动选择集中的全部对象.
If resJig.Status = PromptStatus.Keyword Then
keyword = "A"
'获取等分数量
Dim optfew As New PromptIntegerOptions(vbCrLf & "请输入等分数量")
Dim resfew As PromptIntegerResult = ed.GetInteger(optfew)
If resfew.Status <> PromptStatus.OK Then Return True
few = resfew.Value
ReDim entCopy(0 To few - 1, ids.Length - 1)
For k = 0 To few - 1
For i = 0 To ids.Length - 1
' 复制.
entCopy(k, i) = oldEnt(i).Clone()
Next
Next
Else
If curPt <> targetPt Then
Dim moveMt As Matrix3d = Matrix3d.Displacement(targetPt - curPt)
For i = 0 To ids.Length - 1
entCopy1(i).TransformBy(moveMt)
Next
' 保存当前点.
curPt = targetPt
Return SamplerStatus.OK
Else
Return SamplerStatus.NoChange
End If
End If
ElseIf keyword = "A" Then
' 定义一个点拖动交互类.
Dim optJig As New JigPromptPointOptions(vbCrLf & "请指定第二点[布满(F)]:")
' 设置拖拽光标类型.
optJig.Cursor = CursorType.RubberBand
' 设置拖动光标基点.
optJig.BasePoint = sourcePt
optJig.UseBasePoint = True
'为optJig添加关键字
optJig.Keywords.Add("F", "F", "F", False, True)
'optJig.Keywords.Add("C", "C", "C", False, True)
''默认关键字
'optJig.Keywords.Default = "C"
' 用AcquirePoint函数得到用户输入的点.
Dim resJig As PromptPointResult = prompts.AcquirePoint(optJig)
targetPt = resJig.Value
If resJig.Status = PromptStatus.Keyword Then
keyword = "F"
For k = 0 To few - 1
For i = 0 To ids.Length - 1
' 复制.
entCopy(k, i) = oldEnt(i).Clone()
Next
Next
Else
If curPt <> targetPt Then
'Dim moveMt As Matrix3d = Matrix3d.Displacement((targetPt - curPt) / few * (k + 1))
For k = 0 To few - 1
For i = 0 To ids.Length - 1
entCopy(k, i).TransformBy(Matrix3d.Displacement((targetPt - curPt) * (k + 1)))
Next
Next
' 保存当前点.
curPt = targetPt
Return SamplerStatus.OK
Else
Return SamplerStatus.NoChange
End If
End If
ElseIf keyword = "F" Then
' 定义一个点拖动交互类.
Dim optJig As New JigPromptPointOptions(vbCrLf & "请指定第二点:")
' 设置拖拽光标类型.
optJig.Cursor = CursorType.RubberBand
' 设置拖动光标基点.
optJig.BasePoint = sourcePt
optJig.UseBasePoint = True
' 用AcquirePoint函数得到用户输入的点.
Dim resJig As PromptPointResult = prompts.AcquirePoint(optJig)
targetPt = resJig.Value
' 如果用户拖拽，则用矩阵变换的方法移动选择集中的全部对象.
If curPt <> targetPt Then
'Dim moveMt As Matrix3d = Matrix3d.Displacement((targetPt - curPt) / few * (k + 1))
For k = 0 To few - 1
For i = 0 To ids.Length - 1
entCopy(k, i).TransformBy(Matrix3d.Displacement((targetPt - curPt) / few * (k + 1)))
Next
Next
' 保存当前点.
curPt = targetPt
Return SamplerStatus.OK
Else
Return SamplerStatus.NoChange
End If
End If
End Function
' WorldDraw函数用于刷新屏幕上显示的图形.
Protected Overrides Function WorldDraw(ByVal draw As WorldDraw) As Boolean
If keyword = "C" Then
For i = 0 To ids.Length - 1
' 刷新画面.
draw.Geometry.Draw(entCopy1(i))
Next
Else
For k = 0 To few - 1
For i = 0 To ids.Length - 1
' 刷新画面.
draw.Geometry.Draw(entCopy(k, i))
Next
Next
End If
Return True
End Function
' 将图形对象加入到模型空间的函数.
Public Shared Function AppendEntity(ByVal ent As Entity) As ObjectId
' 得到当前文档图形数据库.
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim entId As ObjectId
Using trans As Transaction = db.TransactionManager.StartTransaction
' 以读方式打开块表.
Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
' 以写方式打开模型空间块表记录.
Dim btr As BlockTableRecord = trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
' 将图形对象的信息添加到块表记录中,并返回ObjectId对象.
entId = btr.AppendEntity(ent)
' 把图形对象添加到事务处理中.
trans.AddNewlyCreatedDBObject(ent, True)
' 提交事务处理.
trans.Commit()
End Using
Return entId
End Function
End Class

Public Class Jig_CCopy 
    ' 从DrawJig类继承. 
    Inherits DrawJig 
    ' 声明全局变量. 
    Dim sourcePt, targetPt, curPt As Point3d 
    Dim keyword As String 
    Dim i, k, few As Integer 
    Dim entCopy(,), entCopy1(), oldEnt() As Entity, ids As ObjectId() 
    Dim db As Database = HostApplicationServices.WorkingDatabase 
    Dim doc As Document = Application.DocumentManager.MdiActiveDocument 
    Dim ed As Editor = doc.Editor 
 
    <CommandMethod("CCopy")> Sub testCCopy() 
 
        keyword = "C" 
 
        Dim res As PromptSelectionResult 
        Dim sSet As SelectionSet 
        Dim opt As New PromptSelectionOptions 
 
        res = ed.SelectImplied() 
 
        If res.Status = PromptStatus.OK Then 
 
            sSet = res.Value 
            ids = sSet.GetObjectIds() 
 
        Else 
            ' 选择集交互操作 
            opt.MessageForAdding = "请选择对象:" 
            opt.AllowDuplicates = True 
            res = ed.GetSelection(opt) 
            If res.Status <> PromptStatus.OK Then Return 
            sSet = res.Value 
            ids = sSet.GetObjectIds() 
 
        End If 
 
        ' 得到基点 
        Dim optPoint As New PromptPointOptions(vbCrLf & "请输入基点:") 
        optPoint.AllowNone = True 
        Dim resPoint As PromptPointResult = ed.GetPoint(optPoint) 
        If resPoint.Status <> PromptStatus.OK Then Return 
        sourcePt = resPoint.Value 
 
        ReDim entCopy1(ids.Length - 1) 
        ReDim oldEnt(ids.Length - 1) 
 
        '获取对象 
        Using trans As Transaction = db.TransactionManager.StartTransaction() 
            For i = 0 To ids.Length - 1 
                oldEnt(i) = trans.GetObject(ids(i), OpenMode.ForWrite) 
            Next 
            trans.Commit() 
        End Using 
 
        Dim lop As Boolean = True 
        '循环 
        Do While lop = True 
 
            For i = 0 To ids.Length - 1 
                ' 将源对象设置为高亮 
                oldEnt(i).Highlight() 
                ' 复制 
                entCopy1(i) = oldEnt(i).Clone() 
            Next 
            ' 设置目标点和拖拽临时点 
            targetPt = sourcePt 
            curPt = targetPt 
 
            ' 开始拖拽. 
            Dim jigRes As PromptResult = ed.Drag(Me) 
            If jigRes.Status = PromptStatus.OK Then 
 
                For i = 0 To ids.Length - 1 
                    AppendEntity(entCopy1(i)) 
                Next 
 
            ElseIf keyword = "A" Then 
 
                targetPt = sourcePt 
                curPt = targetPt 
 
                ' 开始拖拽. 
                jigRes = ed.Drag(Me) 
                If jigRes.Status = PromptStatus.OK Then 
 
                    For k = 0 To few - 1 
                        For i = 0 To ids.Length - 1 
                            AppendEntity(entCopy(k, i)) 
                        Next 
                    Next 
                    ' 取消源对象的高亮状态. 
                    For i = 0 To ids.Length - 1 
                        oldEnt(i).Unhighlight() 
                    Next 
                    '结束循环 
                    lop = False 
 
                ElseIf keyword = "F" Then 
 
                    targetPt = sourcePt 
                    curPt = targetPt 
 
                    ' 开始拖拽. 
                    jigRes = ed.Drag(Me) 
                    If jigRes.Status = PromptStatus.OK Then 
 
                        For k = 0 To few - 1 
                            For i = 0 To ids.Length - 1 
                                AppendEntity(entCopy(k, i)) 
                            Next 
                        Next 
                        ' 取消源对象的高亮状态. 
                        For i = 0 To ids.Length - 1 
                            oldEnt(i).Unhighlight() 
                        Next 
 
                        lop = False 
 
                    Else 
 
                        lop = False 
                        ' 取消源对象的高亮状态. 
                        For i = 0 To ids.Length - 1 
                            oldEnt(i).Unhighlight() 
                        Next 
 
                    End If 
 
                Else 
 
                    lop = False 
                    ' 取消源对象的高亮状态. 
                    For i = 0 To ids.Length - 1 
                        oldEnt(i).Unhighlight() 
                    Next 
 
                End If 
 
            Else 
 
                lop = False 
                ' 取消源对象的高亮状态. 
                For i = 0 To ids.Length - 1 
                    oldEnt(i).Unhighlight() 
                Next 
 
            End If 
 
        Loop 
 
    End Sub 
 
    ' Sampler函数用于检测用户的输入. 
    Protected Overrides Function Sampler(ByVal prompts As JigPrompts) As SamplerStatus 
 
        If keyword = "C" Then 
            Dim optJig As New JigPromptPointOptions(vbCrLf & "请指定第二点[阵列(A)]:") 
            ' 设置拖拽光标类型. 
            optJig.Cursor = CursorType.RubberBand 
            ' 设置拖动光标基点. 
            optJig.BasePoint = sourcePt 
            optJig.UseBasePoint = True 
            '为optJig添加关键字 
            optJig.Keywords.Add("A", "A", "A", False, True) 
            'optJig.Keywords.Add("C", "C", "C", False, True) 
            ''默认关键字 
            'optJig.Keywords.Default = "C" 
            ' 用AcquirePoint函数得到用户输入的点. 
            Dim resJig As PromptPointResult = prompts.AcquirePoint(optJig) 
            targetPt = resJig.Value 
            ' 如果用户拖拽，则用矩阵变换的方法移动选择集中的全部对象. 
            If resJig.Status = PromptStatus.Keyword Then 
                keyword = "A" 
                '获取等分数量 
                Dim optfew As New PromptIntegerOptions(vbCrLf & "请输入等分数量") 
                Dim resfew As PromptIntegerResult = ed.GetInteger(optfew) 
                If resfew.Status <> PromptStatus.OK Then Return True 
                few = resfew.Value 
 
                ReDim entCopy(0 To few - 1, ids.Length - 1) 
 
                For k = 0 To few - 1 
                    For i = 0 To ids.Length - 1 
                        ' 复制. 
                        entCopy(k, i) = oldEnt(i).Clone() 
                    Next 
                Next 
            Else 
                If curPt <> targetPt Then 
                    Dim moveMt As Matrix3d = Matrix3d.Displacement(targetPt - curPt) 
                    For i = 0 To ids.Length - 1 
                        entCopy1(i).TransformBy(moveMt) 
                    Next 
                    ' 保存当前点. 
                    curPt = targetPt 
                    Return SamplerStatus.OK 
                Else 
                    Return SamplerStatus.NoChange 
                End If 
            End If 
        ElseIf keyword = "A" Then 
 
            ' 定义一个点拖动交互类. 
            Dim optJig As New JigPromptPointOptions(vbCrLf & "请指定第二点[布满(F)]:") 
            ' 设置拖拽光标类型. 
            optJig.Cursor = CursorType.RubberBand 
            ' 设置拖动光标基点. 
            optJig.BasePoint = sourcePt 
            optJig.UseBasePoint = True 
            '为optJig添加关键字 
            optJig.Keywords.Add("F", "F", "F", False, True) 
            'optJig.Keywords.Add("C", "C", "C", False, True) 
            ''默认关键字 
            'optJig.Keywords.Default = "C" 
            ' 用AcquirePoint函数得到用户输入的点. 
            Dim resJig As PromptPointResult = prompts.AcquirePoint(optJig) 
            targetPt = resJig.Value 
            If resJig.Status = PromptStatus.Keyword Then 
                keyword = "F" 
                For k = 0 To few - 1 
                    For i = 0 To ids.Length - 1 
                        ' 复制. 
                        entCopy(k, i) = oldEnt(i).Clone() 
                    Next 
                Next 
            Else 
                If curPt <> targetPt Then 
                    'Dim moveMt As Matrix3d = Matrix3d.Displacement((targetPt - curPt) / few * (k + 1)) 
                    For k = 0 To few - 1 
                        For i = 0 To ids.Length - 1 
                            entCopy(k, i).TransformBy(Matrix3d.Displacement((targetPt - curPt) * (k + 1))) 
                        Next 
                    Next 
                    ' 保存当前点. 
                    curPt = targetPt 
                    Return SamplerStatus.OK 
                Else 
                    Return SamplerStatus.NoChange 
                End If 
            End If 
        ElseIf keyword = "F" Then 
 
            ' 定义一个点拖动交互类. 
            Dim optJig As New JigPromptPointOptions(vbCrLf & "请指定第二点:") 
            ' 设置拖拽光标类型. 
            optJig.Cursor = CursorType.RubberBand 
            ' 设置拖动光标基点. 
            optJig.BasePoint = sourcePt 
            optJig.UseBasePoint = True 
 
            ' 用AcquirePoint函数得到用户输入的点. 
            Dim resJig As PromptPointResult = prompts.AcquirePoint(optJig) 
            targetPt = resJig.Value 
            ' 如果用户拖拽，则用矩阵变换的方法移动选择集中的全部对象. 
            If curPt <> targetPt Then 
                'Dim moveMt As Matrix3d = Matrix3d.Displacement((targetPt - curPt) / few * (k + 1)) 
                For k = 0 To few - 1 
                    For i = 0 To ids.Length - 1 
                        entCopy(k, i).TransformBy(Matrix3d.Displacement((targetPt - curPt) / few * (k + 1))) 
                    Next 
                Next 
                ' 保存当前点. 
                curPt = targetPt 
                Return SamplerStatus.OK 
            Else 
                Return SamplerStatus.NoChange 
            End If 
 
        End If 
    End Function 
 ' WorldDraw函数用于刷新屏幕上显示的图形. 
    Protected Overrides Function WorldDraw(ByVal draw As WorldDraw) As Boolean 
        If keyword = "C" Then 
            For i = 0 To ids.Length - 1 
                ' 刷新画面. 
                draw.Geometry.Draw(entCopy1(i)) 
            Next 
        Else 
            For k = 0 To few - 1 
                For i = 0 To ids.Length - 1 
                    ' 刷新画面. 
                    draw.Geometry.Draw(entCopy(k, i)) 
                Next 
            Next 
        End If 
        Return True 
    End Function 
    ' 将图形对象加入到模型空间的函数. 
    Public Shared Function AppendEntity(ByVal ent As Entity) As ObjectId 
        ' 得到当前文档图形数据库. 
        Dim db As Database = HostApplicationServices.WorkingDatabase 
        Dim entId As ObjectId 
        Using trans As Transaction = db.TransactionManager.StartTransaction 
            ' 以读方式打开块表. 
            Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead) 
            ' 以写方式打开模型空间块表记录. 
            Dim btr As BlockTableRecord = trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite) 
            ' 将图形对象的信息添加到块表记录中,并返回ObjectId对象. 
            entId = btr.AppendEntity(ent) 
            ' 把图形对象添加到事务处理中. 
            trans.AddNewlyCreatedDBObject(ent, True) 
            ' 提交事务处理. 
            trans.Commit() 
        End Using 
        Return entId 
    End Function 
End Class

s305040093 · 发表于 2011-12-15 11:18:18

本帖最后由 s305040093 于 2011-12-15 11:50 编辑

res = ed.SelectImplied() 改为
res = ed.SelectPrevious()

sieben · 发表于 2011-12-15 11:30:53

设置了阅读权限,这是在请教问题呢还是在授课?

zlg258369 · 发表于 2011-12-15 15:39:17

sieben 发表于 2011-12-15 11:30
设置了阅读权限,这是在请教问题呢还是在授课?

授课什么意思，注册了就看，没注册就不要看，请教问题只不过是顺带，大不了单开一贴再请教，不知道你回的这啥意思。

zlg258369 · 发表于 2011-12-15 15:42:47

s305040093 发表于 2011-12-15 11:18
res = ed.SelectImplied() 改为
res = ed.SelectPrevious()

res = ed.SelectPrevious()这个不行地。

sieben · 发表于 2011-12-15 16:49:35

zlg258369 发表于 2011-12-15 15:39
授课什么意思，注册了就看，没注册就不要看，请教问题只不过是顺带，大不了单开一贴再请教，不知道你回的 ...

不好意思!我多嘴了,我闭嘴.

xman00 · 发表于 2013-11-4 10:36:28

为何不能先选择对象后输入命令进行执行呢？请大神位完善。顶起

xman00 · 发表于 2013-11-4 10:43:21

本帖最后由 xman00 于 2013-11-4 10:45 编辑

且选择A阵列后，未输入选项（即阵列次数时）按ESC取消时，会跳出要求中止的界面（本人验证仅能选择跳过才能继续），这样就很不方便喽，看能否改善一下哇

账号		自动登录	找回密码
密码			注册

2007仿2012copy

本帖子中包含更多资源