带有视口扭曲的TranslateCoord<>0

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

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 2004  by 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

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