2007仿2012copy
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.StatusPromptStatus.OK Then Return
sSet = res.Value
ids = sSet.GetObjectIds()
End If
**** Hidden Message *****
代码在这里
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
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.StatusPromptStatus.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.StatusPromptStatus.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.StatusPromptStatus.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 curPttargetPt 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 curPttargetPt 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 curPttargetPt 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
res = ed.SelectImplied() 改为
res = ed.SelectPrevious() 设置了阅读权限,这是在请教问题呢还是在授课?
授课什么意思，注册了就看，没注册就不要看，请教问题只不过是顺带，大不了单开一贴再请教，不知道你回的这啥意思。
res = ed.SelectPrevious()这个不行地。
不好意思!我多嘴了,我闭嘴. 为何不能先选择对象后输入命令进行执行呢？请大神位完善。顶起
且选择A阵列后，未输入选项（即阵列次数时）按ESC取消时，会跳出要求中止的界面（本人验证仅能选择跳过才能继续），这样就很不方便喽，看能否改善一下哇
页:
[1]