带视口扭角的translate词<&燃气轮机；0
我在另一个网站上看到了一个有趣的问题想法是在纸空间中选取一个点，并将该点转换为模型空间
在2d环境中，似乎1）将点从图纸空间转换到模型空间
2）通过减去视口扭角将其旋转约0,0
测试I'；首先，在模型空间中绘制一个带有世界ucs和俯视图的矩形
Paperspace有一个视口，具有使用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
现在把它用于3d，我几乎没有成功，我想知道是否有什么是正确的
在视口中，点击topview重置ucs；x->；90然后计划
这将为您提供一个pviewport；有；没有扭曲
运行MsPoint1，你会看到平移坐标没有给出正确的点，所以I'；我现在有点不知所措
；在编写了自己版本的getentity之后，我意识到getentity并不'；t给你实际的点，这肯定会与捕捉对象上的点有关，但我看不出它在一个简单的翻译中是如何起作用的 情况变得更糟了
当您拾取一个点时，活动ucs似乎是视口ucs的ucs
所以平移坐标转换为ucs。由于纸张空间是二维的，因此需要沿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 我有它，现在它#039；它走了，不管怎样都能用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，
我不知道为什么或如何，但这似乎适用于任何视口，没有mattrer what。这可能会提供一些见解。经过大量的尝试和错误，我发现了这种组合
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问题，代码可能会更快，并且也会对其进行明确的修复，以便清楚地看到和记录该问题&引用；你是这方面的老手；，正如米克所说，你的帮助是无价的。谢谢你与我和小组其他成员分享的一切。 谢谢Dave。这是vba的另一部分；我可能不会得到。
页:
[1]