带有视口扭曲的TranslateCoord<>0
我在另一个网站上看到了一个有趣的问题。这个想法是在纸质空间中选择一个点并将该点转换为模型空间。
在2d环境中，似乎
1）将点从纸质空间转换为模型空间
2）将其旋转约0,0减去视口扭曲角。
我正在做的测试是通过在模型空间中绘制一个矩形开始的，其中包含一个世界ucs和一个赢富数据。
纸质空间有一个视口，带有一个扭曲的视图，通过ucs、Z、45->计划类型命令实现。
我们不是想弄清楚一个扭曲的模型空间。
这里有几个测试子
Sub MsPoint1()
Dim VP As Variant
Dim Po As AcadPoint
Dim oDoc As AcadDocument
Dim oUtil As AcadUtility
Dim Zero(2) As Double
Dim oCirc As AcadCircle
Dim Pv As AcadPViewport
Dim vTP As Variant
Set oDoc = ThisDrawing
Set oUtil = oDoc.Utility
ThisDrawing.ActiveSpace = acPaperSpace
oDoc.MSpace = False
Set Pv = ThisDrawing.PaperSpace(1)
VP = oUtil.GetPoint(, "Pick point in paperspace")
Debug.Print Pv.TwistAngle, Pv.TwistAngle * 180 / Pi
Set Po = ThisDrawing.PaperSpace.AddPoint(VP)
vTP = oUtil.TranslateCoordinates(VP, acPaperSpaceDCS, acDisplayDCS, False)
vTP = oUtil.TranslateCoordinates(vTP, acDisplayDCS, acWorld, False)
Set oCirc = oDoc.ModelSpace.AddCircle(vTP, 1)
oCirc.Copy
oCirc.Rotate Zero, -Pv.TwistAngle
oCirc.color = acBlue
End Sub
这个是测试在纸质空间中的旋转首先
除非您取消注释，否则它不起作用。
Sub MsPoint2()
Dim VP As Variant
Dim Po As AcadPoint
Dim oDoc As AcadDocument
Dim oUtil As AcadUtility
Dim Zero(2) As Double
Dim Pzero
Dim oCirc As AcadCircle
Dim Pv As AcadPViewport
Dim vTP As Variant
Set oDoc = ThisDrawing
Set oUtil = oDoc.Utility
ThisDrawing.ActiveSpace = acPaperSpace
oDoc.MSpace = False
Set Pv = ThisDrawing.PaperSpace(1)
Pzero = Zero
VP = oUtil.GetPoint(, "Pick point in paperspace")
Debug.Print Pv.TwistAngle, Pv.TwistAngle * 180 / Pi
Set Po = ThisDrawing.PaperSpace.AddPoint(VP)
Set Po = ThisDrawing.PaperSpace.AddPoint(Zero)
'Pzero = oUtil.TranslateCoordinates(Zero, acWorld, acDisplayDCS, False)
'Pzero = oUtil.TranslateCoordinates(Pzero, acDisplayDCS, acPaperSpaceDCS, False)
'Set Po = ThisDrawing.PaperSpace.AddPoint(Pzero)
'Po.color = acMagenta
Set Po = ThisDrawing.PaperSpace.AddPoint(VP)
Po.Rotate Pzero, -Pv.TwistAngle
VP = Po.Coordinates
vTP = oUtil.TranslateCoordinates(VP, acPaperSpaceDCS, acDisplayDCS, False)
vTP = oUtil.TranslateCoordinates(vTP, acDisplayDCS, acWorld, False)
Set oCirc = oDoc.ModelSpace.AddCircle(vTP, 1)
oCirc.color = acGreen
End Sub
**** Hidden Message ***** 现在将其用于3d＜br＞我几乎没有成功，我想知道是否有什么是正确的
在视口中，点击topview重置ucs
ucs->x->90，然后规划
这将为您提供无扭曲的pviewport
运行MsPoint1，您将看到TranslateCoordinates没有给出正确的点
，因此我在这一点上有点不知所措
在编写了我自己版本的getentity之后，我意识到getentity并没有给你实际的分数
，这肯定会与捕捉对象上的点一起发挥作用，但我看不出在简单的翻译中它是如何发挥作用的 情况变得更糟。
当您选择一个点时，活动的 ucs 似乎是视口 ucs 的 ucs。
因此，TranslateCoordinates翻译成ucs。由于paperspace是2d的，因此您需要沿着viewdir翻译到拾取的对象，以找到现实世界的坐标。
这个子应用程序工作（直到你去模型空间）
Sub MsPoint1a()
Dim VP As Variant
Dim Po As AcadPoint
Dim oDoc As AcadDocument
Dim oUtil As AcadUtility
Dim Zero(2) As Double
Dim oCirc As AcadCircle
Dim Pv As AcadPViewport
Dim vTP As Variant
Dim UcsMspace As AcadUCS
Dim UcsModelspace As AcadUCS
Set oDoc = ThisDrawing
Set oUtil = oDoc.Utility
ThisDrawing.ActiveSpace = acPaperSpace
oDoc.MSpace = False
Set Pv = ThisDrawing.PaperSpace(1)
VP = oUtil.GetPoint(, "Pick point in paperspace")
Set Po = ThisDrawing.PaperSpace.AddPoint(VP)
vTP = oUtil.TranslateCoordinates(VP, acPaperSpaceDCS, acDisplayDCS, False)
oDoc.MSpace = True
vTP = oUtil.TranslateCoordinates(vTP, acDisplayDCS, acUCS, False)
vTP = oUtil.TranslateCoordinates(vTP, acUCS, acWorld, False)
Set oCirc = oDoc.ModelSpace.AddCircle(vTP, 1)
oCirc.Copy
oCirc.Rotate Zero, -Pv.TwistAngle
oCirc.color = acBlue
End Sub
我有了它，现在它消失了，这无论如何都有效
Option Explicit
Private Declare Function GetCursor Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Function ConvertPaperSpacePtToModelspace(Pt As Variant, Vp As AcadPViewport)
Dim oDoc As AcadDocument
Dim oUtil As AcadUtility
Dim Ent As AcadEntity
Dim oPt As AcadPoint
Dim Zero(2) As Double
Set oDoc = ThisDrawing
Set oUtil = oDoc.Utility
Pt = oUtil.TranslateCoordinates(Pt, acPaperSpaceDCS, acDisplayDCS, False)
ThisDrawing.MSpace = True
Pt = oUtil.TranslateCoordinates(Pt, acDisplayDCS, acWorld, False)
Set Ent = SelectAtPt(, , Pt)
Pt = PickPtToEnt(Ent, Pt)
Set oPt = oDoc.ModelSpace.AddPoint(Pt)
'oPt.Rotate Zero, -Vp.TwistAngle
oPt.color = acRed
oDoc.MSpace = False
End Function
Sub TestMsPoint()
Dim Vpt As Variant
Dim oDoc As AcadDocument
Dim oUtil As AcadUtility
Dim Pv As AcadPViewport
Set oDoc = ThisDrawing
Set oUtil = oDoc.Utility
ThisDrawing.ActiveSpace = acPaperSpace
oDoc.MSpace = False
Set Pv = ThisDrawing.PaperSpace(1)
Vpt = oUtil.GetPoint(, "Pick point in paperspace")
ConvertPaperSpacePtToModelspace Vpt, Pv
End Sub
和几个函数
Private Function PickPtToEnt(Ent As AcadEntity, v) As Variant
Dim Dir, N
Dim newV(2) As Double
Dim Dist As Double
Dim dOrigin As Variant
Dim Z As Double, Pt
N = Ent.Normal
Dir = ToWcs(ThisDrawing.GetVariable("viewdir")) '''
If TypeOf Ent Is AcadLWPolyline Then
Z = Ent.Elevation
Else
Pt = Ent.Center
Z = (Pt(0) * N(0)) + (Pt(1) * N(1)) + (Pt(2) * N(2))
End If
Dir = SubtractVectors(Dir, ThisDrawing.GetVariable("ucsorg"))
Dist = (Z - (v(0) * N(0)) - (v(1) * N(1)) - (v(2) * N(2))) _
/ ((Dir(0) * N(0)) + (Dir(1) * N(1)) + (Dir(2) * N(2)))
newV(0) = v(0) + Dist * Dir(0)
newV(1) = v(1) + Dist * Dir(1)
newV(2) = v(2) + Dist * Dir(2)
PickPtToEnt = newV
ThisDrawing.ModelSpace.AddPoint newV
End Function
Function ToWcs(Pt As Variant) As Variant
ToWcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acUCS, acWorld, False)
End Function
Function SubtractVectors(V1, V2) As Variant
Dim V3(2) As Double
V3(0) = V1(0) - V2(0)
V3(1) = V1(1) - V2(1)
V3(2) = V1(2) - V2(2)
SubtractVectors = V3
End Function
Public Function SelectAtPt(Optional ObType As String, Optional msg As String = "Pick:", Optional varPick As Variant, _
Optional ssName As String = "SS") As AcadEntity
'ObType="LWPolyline" or "Circle","Line","Insert","Viewport"
Dim oSSet As AcadSelectionSet
Dim oSSets As AcadSelectionSets
Dim Pt1(2) As Double, Pt2(2) As Double
Dim FType(0) As Integer
Dim FData(0) As Variant
Dim i As Integer, x
FType(0) = 0
FData(0) = ObType
If IsMissing(varPick) Then
'varPick = GetPointEX(, msg)
varPick = ThisDrawing.Utility.GetPoint(, msg)
End If
If IsEmpty(varPick) Then Exit Function ''''''''''''''''
x = CursorSelection(varPick)
For i = 0 To 2
Pt1(i) = x(i)
Pt2(i) = x(i + 3)
Next
Set oSSets = ThisDrawing.SelectionSets
DeleteSelectionSet ssName
Set oSSet = oSSets.Add(ssName)
If ObType = "" Then
oSSet.Select acSelectionSetCrossing, Pt1, Pt2
Else
oSSet.Select acSelectionSetCrossing, Pt1, Pt2, FilterType:=FType, FilterData:=FData
End If
Select Case oSSet.Count
Case 0
Case 1
Set SelectAtPt = oSSet(0)
Case Else
oSSet.Highlight True
End Select
oSSet.Delete
End Function
'CCP Jan 8 2004 Revised April 3 2004by Troy Williams
Public Function CursorSelection(varPick As Variant)
If IsEmpty(varPick) Then Exit Function ''''''''''''''''
'varpick comes in as a wcs value
Dim dStart(0 To 2) As Double
Dim dEnd(0 To 2) As Double
Dim vTemp As Variant
Dim pts(5) As Double
Dim R As RECT' receives window rectangle in pixels
Dim RetVal As Long' return value
Dim pixelHeight As Double
Dim dblDist As Double
RetVal = GetWindowRect(ThisDrawing.hwnd, R)
pixelHeight = R.Bottom - R.Top
dblDist = (ThisDrawing.GetVariable("pickbox") / pixelHeight) * ThisDrawing.GetVariable("viewsize")
dblDist = dblDist * 1.04
vTemp = ThisDrawing.Utility.TranslateCoordinates(varPick, acWorld, acUCS, False) ''''''''''''''
dStart(0) = vTemp(0) - dblDist: dStart(1) = vTemp(1) - dblDist: dStart(2) = vTemp(2)
dEnd(0) = vTemp(0) + dblDist: dEnd(1) = vTemp(1) + dblDist: dEnd(2) = vTemp(2)
pts(0) = dStart(0)
pts(1) = dStart(1)
pts(2) = dStart(2)
pts(3) = dEnd(0)
pts(4) = dEnd(1)
pts(5) = dEnd(2)
CursorSelection = pts
'ThisDrawing.GetVariable("pickbox")=pixels?
'pixelHeight=windows api height of active screen in pixels
'ThisDrawing.GetVariable("viewsize")=Stores the height of the view in the current viewport. Expressed in drawing units
End Function
Public Function DeleteSelectionSet(SSetName As String)
Dim SSets As AcadSelectionSets
Dim sset As AcadSelectionSet
Set SSets = ThisDrawing.SelectionSets
For Each sset In SSets
If sset.Name = SSetName Then
sset.Delete
Exit For
End If
Next
Set SSets = Nothing
End Function
Bryco，
我不确定为什么或如何，但这似乎适用于我的任何视口，没有更小的东西。它可能会提供一些见解。经过大量的尝试错误，我遇到了这种组合。
thisdrawing.ActiveSpace = acPaperSpace
thisdrawing.SendCommand "_ucs" & vbCr & "w" & vbCr
thisdrawing.MSpace = False
Set ActLayout = thisdrawing.ActiveLayout
Set util = thisdrawing.Utility
returnPnt1 = thisdrawing.Utility.GetPoint(, "Enter point inside of the viewport you wish to add balloons to: ")
Dim MyViewPortHandle As String
For Each Ent In thisdrawing.PaperSpace
If LCase(Ent.ObjectName) = "acdbviewport" And _
LCase(Ent.Layer)"0" Then
Set currView = Ent
MyViewPortHandle = currView.Handle
currView.GetBoundingBox minExt, maxExt
ViewportX = Round(maxExt(0) - minExt(0), 5)
ViewportY = Round(maxExt(1) - minExt(1), 5)
ViewportZ = Round(maxExt(2) - minExt(2), 5)
If returnPnt1(0) > minExt(0) And _
returnPnt1(0)minExt(1) And _
returnPnt1(1) < maxExt(1) Then
HoldPoint1(0) = minExt(0)
HoldPoint1(1) = minExt(1)
HoldPoint1(2) = 0
HoldPoint2(0) = maxExt(0)
HoldPoint2(1) = maxExt(1)
HoldPoint2(2) = 0
GoTo translateNow
End If
End If
Next
translateNow:
thisdrawing.ActiveSpace = acPaperSpace
thisdrawing.MSpace = True
thisdrawing.ActivePViewport = currView
thisdrawing.SendCommand "_ucs" & vbCr & "v" & vbCr
P1 = HoldPoint1
P2 = HoldPoint2
P1 = util.TranslateCoordinates(P1, acPaperSpaceDCS, acDisplayDCS, False)
M1 = util.TranslateCoordinates(P1, acDisplayDCS, acUCS, False)
P2 = util.TranslateCoordinates(P2, acPaperSpaceDCS, acDisplayDCS, False)
M2 = util.TranslateCoordinates(P2, acDisplayDCS, acUCS, False)
thisdrawing.ActiveSpace = acPaperSpace
thisdrawing.MSpace = True
thisdrawing.ActivePViewport = currView
thisdrawing.SendCommand "_ucs" & vbCr & "v" & vbCr
On Error Resume Next
thisdrawing.SelectionSets("newselset").Delete
On Error GoTo ET
Set ssobjects = thisdrawing.SelectionSets.Add("newselset")
ssobjects.SelectOnScreen
Dim MinValue As Double
Dim MaxValue As Double
Dim MidValue As Double
On Error Resume Next
For Each Ent In ssobjects
If LCase(Ent.ObjectName) = "acdb3dsolid" Then
Set MySolid = Ent
thisdrawing.MSpace = True
thisdrawing.SendCommand "_ucs" & vbCr & "w" & vbCr
Dim momentOfInertia As Variant
momentOfInertia = MySolid.Centroid
M1 = momentOfInertia
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
thisdrawing.MSpace = False
Set MSpt = thisdrawing.PaperSpace.AddPoint(P1)
MSpt.Color = 30
End If
Next
谢谢Dave
但是看起来你也在做类似的事情。我们都在改变mspace以获得正确的翻译。
如何在不改变的情况下做到这一点是关键。 你的代码令人印象深刻。我一直在看它，变得非常不耐烦，因为我想尝试一下。我现在的事情太多了。我只是在使用质心，所以我觉得我的代码不能用于自动标注模块，但你的代码会<在我忘记之前，我似乎记得在我所有的尝试和错误中，我通过将regen插入到混合中得到了一些混合结果。也许问题是由视口兑现引起的？这只是一个猜测，但如果我们能够以一种优雅的方式解决UCS问题，代码可能会更快，并且也会对其进行明确的修复，以便清楚地看到并记录该问题。正如米克所说，“你是这方面的老手”，你的帮助是无价的。感谢您与我和小组其他成员分享的一切。 谢谢戴夫。这是vba的另一部分，我可能不会得到。
页:
[1]