I had it and now it's gone, this works anyway
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
And a couple of functions
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
