topic Re: in VBA Forum

Why doesn't this work? Put me out of my misery!

Anonymous — Sat, 25 Nov 2000 14:20:37 GMT

I have been struggling for a week, on and off, with both AutoLisp and now
VBA, to write a routine to rotate a layout (pspace objects including
viewports and views) through 90 degrees. I am a novice at both languages, so
excuse any crudities in the routine below.

The macro works right up to the last point, which is to restore the centre
of the view. I just cannot get it to work (I've tried using Direction and
Target properties). What am I doing wrong???

thanks!

Sub RotateLayout()

On Error GoTo Errorhandler

Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")

ssetObj.SelectOnScreen

Dim objCount As Integer
Dim I As Integer

objCount = ssetObj.Count

Dim pspaceObj As AcadEntity
Dim basept As Variant
Dim rotAngle As Double
Dim origin(0 To 2) As Double

origin(0) = 0#
origin(1) = 0#
origin(2) = 0#
rotAngle = -1.5708
basept = ThisDrawing.Utility.GetPoint(, "Enter the point which will be
at 0,0 after rotation: ")

For I = 0 To objCount - 1
Set pspaceObj = ssetObj.Item(I)
pspaceObj.Move basept, origin
pspaceObj.Rotate origin, rotAngle
Next

Dim vpObj As AcadPViewport
Dim currWidth, currHeight As Double
Dim vpTarget As Variant
Dim custScale, stdScale As Double

For I = 0 To objCount - 1
Set pspaceObj = ssetObj.Item(I)
If (pspaceObj.ObjectName = "AcDbViewport") Then
Set vpObj = ssetObj.Item(I)

'get current settings
currWidth = vpObj.Width
currHeight = vpObj.Height
vpTarget = vpObj.Target
custScale = vpObj.CustomScale
stdScale = vpObj.StandardScale

'swap width/height
vpObj.Width = currHeight
vpObj.Height = currWidth
vpObj.update

'go to mspace, turn UCS, set plan, return UCS
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = vpObj
ThisDrawing.SendCommand "_ucs" & vbCr & "z" & vbCr & "90" & vbCr
ThisDrawing.SendCommand "_plan" & vbCr & "current" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "prev" & vbCr
ThisDrawing.MSpace = False

'turn display off while returning previous settings then turn back on

vpObj.Display False
vpObj.StandardScale = stdScale
vpObj.CustomScale = custScale
vpObj.Target = vpTarget
vpObj.Display True
vpObj.Update
ThisDrawing.Regen acAllViewports

End If

Next

Errorhandler:

ssetObj.Delete
ZoomExtents

End Sub

-------------------------------------------------
Keith Pocock
mailto:keithlp@breathemail.net

Re: Why doesn't this work? Put me out of my misery!

Anonymous — Sun, 26 Nov 2000 14:21:12 GMT

Update -

What exactly is the .Target property? I thought it was the VB version of
the view centre (ie. the modelspace view contained within the paperspace
viewport), but it seems that it is not.

If I query a viewport the target is ALWAYS 0,0 unless it has already been
specfically set by some previous VB code. Furthermore, I have now got the
view to change by altering the value of the target property of the viewport,
but the coordinate passed does not become the centre of the view.

Really confused now. How do you query/set the view shown through a
PViewport?

thanks

"Keith Pocock" wrote in message
news:1E20A4CCAA6E59DBDFE152626F066CAB@in.WebX.SaUCah8kaAW...
>
> I have been struggling for a week, on and off, with both AutoLisp and now
> VBA, to write a routine to rotate a layout (pspace objects including
> viewports and views) through 90 degrees. I am a novice at both languages,
so
> excuse any crudities in the routine below.
>
> The macro works right up to the last point, which is to restore the centre
> of the view. I just cannot get it to work (I've tried using Direction and
> Target properties). What am I doing wrong???
>
> thanks!
>
> Sub RotateLayout()
>
> On Error GoTo Errorhandler
>
> Dim ssetObj As AcadSelectionSet
> Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
>
> ssetObj.SelectOnScreen
>
> Dim objCount As Integer
> Dim I As Integer
>
> objCount = ssetObj.Count
>
> Dim pspaceObj As AcadEntity
> Dim basept As Variant
> Dim rotAngle As Double
> Dim origin(0 To 2) As Double
>
> origin(0) = 0#
> origin(1) = 0#
> origin(2) = 0#
> rotAngle = -1.5708
> basept = ThisDrawing.Utility.GetPoint(, "Enter the point which will be
> at 0,0 after rotation: ")
>
> For I = 0 To objCount - 1
> Set pspaceObj = ssetObj.Item(I)
> pspaceObj.Move basept, origin
> pspaceObj.Rotate origin, rotAngle
> Next
>
> Dim vpObj As AcadPViewport
> Dim currWidth, currHeight As Double
> Dim vpTarget As Variant
> Dim custScale, stdScale As Double
>
> For I = 0 To objCount - 1
> Set pspaceObj = ssetObj.Item(I)
> If (pspaceObj.ObjectName = "AcDbViewport") Then
> Set vpObj = ssetObj.Item(I)
>
> 'get current settings
> currWidth = vpObj.Width
> currHeight = vpObj.Height
> vpTarget = vpObj.Target
> custScale = vpObj.CustomScale
> stdScale = vpObj.StandardScale
>
> 'swap width/height
> vpObj.Width = currHeight
> vpObj.Height = currWidth
> vpObj.update
>
> 'go to mspace, turn UCS, set plan, return UCS
> ThisDrawing.MSpace = True
> ThisDrawing.ActivePViewport = vpObj
> ThisDrawing.SendCommand "_ucs" & vbCr & "z" & vbCr & "90" & vbCr
> ThisDrawing.SendCommand "_plan" & vbCr & "current" & vbCr
> ThisDrawing.SendCommand "ucs" & vbCr & "prev" & vbCr
> ThisDrawing.MSpace = False
>
> 'turn display off while returning previous settings then turn back on
>
> vpObj.Display False
> vpObj.StandardScale = stdScale
> vpObj.CustomScale = custScale
> vpObj.Target = vpTarget
> vpObj.Display True
> vpObj.Update
> ThisDrawing.Regen acAllViewports
>
> End If
>
> Next
>
> Errorhandler:
>
> ssetObj.Delete
> ZoomExtents
>
> End Sub
>
> -------------------------------------------------
> Keith Pocock
> mailto:keithlp@breathemail.net
>

Re: Why doesn't this work? Put me out of my misery!

Anonymous — Mon, 13 Jan 2003 16:18:48 GMT

WriteXrecord "Test", "SectionLst", 300, "((0) (1 2 3))"
GetXrecord "Test", "SectionLst", XRecordDataType, gv_SectionList

Public Sub GetXrecord(dName As String, keyName As String, xType, xData)

On Error GoTo ErrHandler

Dim dic As AcadDictionary, xrec As AcadXRecord

Set xrec = ThisDrawing.Dictionaries.Item(dName)
xrec.GetXRecordData xType, xData

Exit Sub

ErrHandler:

xType = Array(300)
xData = Array("")

End Sub

Public Sub GetXrecord(dName As String, keyName As String, xType, xData)

On Error GoTo ErrHandler

Dim dic As AcadDictionary, xrec As AcadXRecord

Set xrec = ThisDrawing.Dictionaries.Item(dName)
xrec.GetXRecordData xType, xData

Exit Sub

ErrHandler:

xType = Array(300)
xData = Array("")

End Sub

These are routines found at Franks site by the way.
The "Set xrec ..." line in GetXrecord fails even though I can see it in the
dictionaries collection using the watch window.

Dale

Re:

Anonymous — Tue, 14 Jan 2003 10:11:45 GMT

Bang!

Dale, it would be a bad idea to attempt to explicitly force arbitrary values
for the variants with the error handler. After all, those subs could be used
in the same project for many different XRecords.

Your error handler should be in the calling procedures.

Public Sub GetXrecord(dName As String, keyName As String, xType, xData)
On Error Resume Next ' <- Note change from online code!
Dim dic As AcadDictionary, xrec As AcadXRecord
Set dic = ThisDrawing.Dictionaries(dName)
Set xrec = dic.Item(keyName)
xrec.GetXRecordData xType, xData
End Sub

Function HasElements(ByVal ArrayToCheck As Variant) As Boolean
On Error Resume Next
HasElements = (LBound(ArrayToCheck) <= UBound(ArrayToCheck))
End Function

Public Sub Test()
Dim MyType, MyData
GetXrecord "MW Drawing Info", "PrimarySF", MyType, MyData
If HasElements(MyType) Then
Debug.Print "Found data."
Else
Debug.Print "No data!"
End If
End Sub

--
R. Robert Bell, MCSE
www.AcadX.com

"Dale Levesque" wrote in message
news:29DD2EF030E42DC21822A304CEAB1A35@in.WebX.maYIadrTaRb...
| WriteXrecord "Test", "SectionLst", 300, "((0) (1 2 3))"
| GetXrecord "Test", "SectionLst", XRecordDataType, gv_SectionList
|
| Public Sub GetXrecord(dName As String, keyName As String, xType, xData)
|
| On Error GoTo ErrHandler
|
| Dim dic As AcadDictionary, xrec As AcadXRecord
|
| Set xrec = ThisDrawing.Dictionaries.Item(dName)
| xrec.GetXRecordData xType, xData
|
| Exit Sub
|
| ErrHandler:
|
| xType = Array(300)
| xData = Array("")
|
| End Sub
|
| Public Sub GetXrecord(dName As String, keyName As String, xType, xData)
|
| On Error GoTo ErrHandler
|
| Dim dic As AcadDictionary, xrec As AcadXRecord
|
| Set xrec = ThisDrawing.Dictionaries.Item(dName)
| xrec.GetXRecordData xType, xData
|
| Exit Sub
|
| ErrHandler:
|
| xType = Array(300)
| xData = Array("")
|
| End Sub
|
| These are routines found at Franks site by the way.
| The "Set xrec ..." line in GetXrecord fails even though I can see it in
the
| dictionaries collection using the watch window.
|
| Dale
|
|