VBA / ViewDirections / ZoomCenter

Peter Busch
Peter Busch
in Programming and customization

<

div>

Can be usefull to define a Viewpath. At first we define some Views 1 ... N (ViewCenterPoints / CameraPoints / ViewDirections) .

Then there will be activate each View 1 ... N and ZoomIn with the ZoomCenter command - with a ZoomWidth.

To test it and describe the problem here [--> end of text] are two VBA-Routines - witch are running seperate.

 

Routine01 / TopViews / 'ViewPoint-Vertical = + 90°

Routine02 / IsoViews / 'ViewPoint-Vertical < +90°

Both routines are in principe identical. The only difference is under Pt.2a) Definition CameraPoints 

 

Routine01 / TopViews

ZoomCenter works only correctly with a "ViewPointSetting H=270°V=+90°"

If we use the Tool SetViewpoint -  before start Routine01 - can be set a other Viewpoint, f.E. H=210°V=+90°,

The ZoomCenter works then with this Horizontal-Viewpoint H<>270° rightly.

The Problem is:

The same Horizontal-Viewpoint-Setting H<>270° cannot be activate from VBA .

If we place the command [ThisDrawing.SendCommand "VPOINT R 240 90 "] in Routine01 - the result is always with a "ViewPointSetting H=270°V=90°".  

Routine02 / IsoViews / 'ViewPoint-Vertical < +90°

Problem:

The ZoomCenter works rightly only for the 1. View ?

But Views 2 ... N  have results - that all Objects move more and more outside the Display.

The ZoomCenter don't 'zoom here to the "ZoomPoint ZCPt()".

Who have experience to solve this problem- so that the VBA-ZoomCenter works for user-defined ViewDirections ?

Best Regards

 

Peter Busch

 

'TestRoutine01 / TopViews / 'ViewPoint-Vertical = + 90°

 Public Sub ViewDirection_ZoomCenter_TopView()

'-----------------------------------------------------------------

   On Error Resume Next

 

   Dim ObjEnti As AcadEntity

   For Each ObjEnti In ThisDrawing.ModelSpace

     ObjEnti.Delete

   Next

  

   ThisDrawing.ActiveSpace = acModelSpace

  

  'Active Viewport1

   Dim AVPort1 As AcadViewport

   Set AVPort1 = ThisDrawing.ActiveViewport

 

  'NbrOfViews 1 ... N

   Dim NbrOfViews As Long, ActiveView As Long

   NbrOfViews = 10  ' >1 & < 100

  

  '1a) ViewCenterPoints 1 ... N

   Dim ViewCtr(99, 0 To 2) As Double

  'StartPoint / X-Y

   ViewCtr(1, 0) = 0.5: ViewCtr(1, 1) = 1

  'Point2...N / X-Y

   For ActiveView = 2 To NbrOfViews

     ViewCtr(ActiveView, 0) = ViewCtr(ActiveView - 1, 0) + 20 * Rnd + 5

     ViewCtr(ActiveView, 1) = ViewCtr(ActiveView - 1, 1) + 20 * Rnd + 5

   Next

  'Elevation

   For ActiveView = 1 To NbrOfViews

     ViewCtr(ActiveView, 2) = 1

   Next

 

  '1b) Show ViewCenterPoints

   Dim CenterPointObj As Acad3DSolid, CtrXYZ(0 To 2) As Double

   Dim TextStr As String, TxOb1 As AcadText

   For ActiveView = 1 To NbrOfViews

     CtrXYZ(0) = ViewCtr(ActiveView, 0)

     CtrXYZ(1) = ViewCtr(ActiveView, 1)

     CtrXYZ(2) = ViewCtr(ActiveView, 2)

     Set CenterPointObj = ThisDrawing.ModelSpace.AddCylinder(CtrXYZ, 2, 2)

     CenterPointObj.color = acGreen '(Nbr + 3) * 10

     CenterPointObj.LAYER = "0"

    '--------------------------

     TextStr = Str(ActiveView)

     Set TxOb1 = ThisDrawing.ModelSpace. _

                 AddText(TextStr, CtrXYZ, 2)

     TxOb1.LAYER = "0"

     TxOb1.color = acRed

     TxOb1.Lineweight = acLnWt035

     TxOb1.Alignment = acAlignmentLeft

     TxOb1.TextAlignmentPoint = CtrXYZ

   Next

 

 

 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

  '2a) CameraPoints 1 ... N

  'Top_View / Vertical = +90 Deg.

  'CameraPoint - for each ViewCenter / 20m over the ViewCenter

   Dim ViewCam(99, 0 To 2) As Double

   For ActiveView = 1 To NbrOfViews

     ViewCam(ActiveView, 0) = ViewCtr(ActiveView, 0)

     ViewCam(ActiveView, 1) = ViewCtr(ActiveView, 1)

     ViewCam(ActiveView, 2) = ViewCtr(ActiveView, 2) + 20

   Next

  'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

  'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

 

   

  '2b) Show CameraPoints

   Dim CameraPointObj As Acad3DSolid, CamXYZ(0 To 2) As Double

   For ActiveView = 1 To NbrOfViews

     CamXYZ(0) = ViewCam(ActiveView, 0)

     CamXYZ(1) = ViewCam(ActiveView, 1)

     CamXYZ(2) = ViewCam(ActiveView, 2)

     Set CameraPointObj = ThisDrawing.ModelSpace.AddSphere(CamXYZ, 1.5)

     CameraPointObj.color = acMagenta  '6 * Rnd

     CameraPointObj.LAYER = "0"

    '--------------------------

     TextStr = Str(ActiveView)

     Set TxOb1 = ThisDrawing.ModelSpace. _

                 AddText(TextStr, CamXYZ, 2)

     TxOb1.LAYER = "0"

     TxOb1.color = acYellow

     TxOb1.Lineweight = acLnWt035

     TxOb1.Alignment = acAlignmentLeft

     TxOb1.TextAlignmentPoint = CamXYZ

   Next

 

 

  '3. Calc ViewDirections // ViewCam(...) ---> ViewCtr(...)

   Dim ViewDir(99, 0 To 2) As Double

   Dim dX As Double, dY As Double, dZ As Double

   Dim Dist As Double

   For ActiveView = 1 To NbrOfViews

     dX = ViewCtr(ActiveView, 0) - ViewCam(ActiveView, 0)

     dY = ViewCtr(ActiveView, 1) - ViewCam(ActiveView, 1)

     dZ = ViewCtr(ActiveView, 2) - ViewCam(ActiveView, 2)

     Dist = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))

     ViewDir(ActiveView, 0) = -(dX / Dist)

     ViewDir(ActiveView, 1) = -(dY / Dist)

     ViewDir(ActiveView, 2) = -(dZ / Dist)

   Next

 

 

  '4. Set ViewDirection & ZoomIn with width ZWid

   Dim ZCPt(0 To 2) As Double, ZWid As Double

   Dim VDir(0 To 2) As Double

   ZWid = 30

   For ActiveView = 1 To NbrOfViews

    '4.1

     VDir(0) = ViewDir(ActiveView, 0)

     VDir(1) = ViewDir(ActiveView, 1)

     VDir(2) = ViewDir(ActiveView, 2)

     AVPort1.Direction = VDir

    '4.2

    'ZoomIn

     ZCPt(0) = ViewCtr(ActiveView, 0)

     ZCPt(1) = ViewCtr(ActiveView, 1)

     ZCPt(2) = ViewCtr(ActiveView, 2)

     ZoomCenter ZCPt, ZWid

    'ThisDrawing.Regen acActiveViewport

   Next

  

 End Sub

 'Routine01 / TopViews / 'ViewPoint-Vertical = + 90°

 

   

  'TestRoutine02 / IsoViews / 'ViewPoint-Vertical < +90°

 

  Public Sub ViewDirection_ZoomCenter_IsoViews()

  '-----------------------------------------------------------------

   On Error Resume Next

 

<

p class="MsoNormal" style="margin: 0cm 0cm 0pt;">    Dim ObjEnti As AcadEntity

</font>

Comments

  • Peter Busch
    Peter Busch

    'TestRoutine02 / IsoViews / 'ViewPoint-Vertical < +90°

    Public Sub ViewDirection_ZoomCenter_IsoViews()
    '-----------------------------------------------------------------
       On Error Resume Next
     
       Dim ObjEnti As AcadEntity
       For Each ObjEnti In ThisDrawing.ModelSpace
         ObjEnti.Delete
       Next
      
       ThisDrawing.ActiveSpace = acModelSpace
       
       
      'Active Viewport1
       Dim AVPort1 As AcadViewport
       Set AVPort1 = ThisDrawing.ActiveViewport

      'NbrOfViews 1 ... N
       Dim NbrOfViews As Long, ActiveView As Long
       NbrOfViews = 10  ' >1 & < 100
      
      
      '1a) ViewCenterPoints 1 ... N
       Dim ViewCtr(99, 0 To 2) As Double
      'StartPoint / X-Y
       ViewCtr(1, 0) = 0.5: ViewCtr(1, 1) = 1
      'Point2...N / X-Y
       For ActiveView = 2 To NbrOfViews
         ViewCtr(ActiveView, 0) = ViewCtr(ActiveView - 1, 0) + 20 * Rnd + 5
         ViewCtr(ActiveView, 1) = ViewCtr(ActiveView - 1, 1) + 20 * Rnd + 5
       Next
      'Elevation
       For ActiveView = 1 To NbrOfViews
         ViewCtr(ActiveView, 2) = 1
       Next
     
      '1b) Show ViewCenterPoints
       Dim CenterPointObj As Acad3DSolid, CtrXYZ(0 To 2) As Double
       Dim TextStr As String, TxOb1 As AcadText
       For ActiveView = 1 To NbrOfViews
         CtrXYZ(0) = ViewCtr(ActiveView, 0)
         CtrXYZ(1) = ViewCtr(ActiveView, 1)
         CtrXYZ(2) = ViewCtr(ActiveView, 2)
         Set CenterPointObj = ThisDrawing.ModelSpace.AddCylinder(CtrXYZ, 2, 2)
         CenterPointObj.color = acGreen '(Nbr + 3) * 10
         CenterPointObj.LAYER = "0"
        '--------------------------
         TextStr = Str(ActiveView)
         Set TxOb1 = ThisDrawing.ModelSpace. _
                     AddText(TextStr, CtrXYZ, 2)
         TxOb1.LAYER = "0"
         TxOb1.color = acRed
         TxOb1.Lineweight = acLnWt035
         TxOb1.Alignment = acAlignmentLeft
         TxOb1.TextAlignmentPoint = CtrXYZ
       Next
     
     
      'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      '2a) CameraPoints 1 ... N
      'Iso_View / Vertical < +90 Deg.
       Dim ViewCam(99, 0 To 2) As Double
       For ActiveView = 1 To NbrOfViews
         ViewCam(ActiveView, 0) = ViewCtr(ActiveView, 0) - 5 - 5 * Rnd
         ViewCam(ActiveView, 1) = ViewCtr(ActiveView, 1) - 5 - 5 * Rnd
         ViewCam(ActiveView, 2) = ViewCtr(ActiveView, 2) + 10
       Next
      'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
     
     
      '2b) Show CameraPoints
       Dim CameraPointObj As Acad3DSolid, CamXYZ(0 To 2) As Double
       For ActiveView = 1 To NbrOfViews
         CamXYZ(0) = ViewCam(ActiveView, 0)
         CamXYZ(1) = ViewCam(ActiveView, 1)
         CamXYZ(2) = ViewCam(ActiveView, 2)
         Set CameraPointObj = ThisDrawing.ModelSpace.AddSphere(CamXYZ, 1.5)
         CameraPointObj.color = acMagenta  '6 * Rnd
         CameraPointObj.LAYER = "0"
        '--------------------------
         TextStr = Str(ActiveView)
         Set TxOb1 = ThisDrawing.ModelSpace. _
                     AddText(TextStr, CamXYZ, 2)
         TxOb1.LAYER = "0"
         TxOb1.color = acYellow
         TxOb1.Lineweight = acLnWt035
         TxOb1.Alignment = acAlignmentLeft
         TxOb1.TextAlignmentPoint = CamXYZ
       Next

     
      '3. Calc ViewDirections // ViewCam(...) ---> ViewCtr(...)
       Dim ViewDir(99, 0 To 2) As Double
       Dim dX As Double, dY As Double, dZ As Double
       Dim Dist As Double
       For ActiveView = 1 To NbrOfViews
         dX = ViewCtr(ActiveView, 0) - ViewCam(ActiveView, 0)
         dY = ViewCtr(ActiveView, 1) - ViewCam(ActiveView, 1)
         dZ = ViewCtr(ActiveView, 2) - ViewCam(ActiveView, 2)
         Dist = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))
         ViewDir(ActiveView, 0) = -(dX / Dist)
         ViewDir(ActiveView, 1) = -(dY / Dist)
         ViewDir(ActiveView, 2) = -(dZ / Dist)
       Next
       
      '4. Set ViewDirection & ZoomIn with width ZWid
       Dim ZCPt(0 To 2) As Double, ZWid As Double
       Dim VDir(0 To 2) As Double
       Dim VCtr(0 To 2) As Double
      
       ZWid = 50
       For ActiveView = 1 To NbrOfViews
        '4.1
         VDir(0) = ViewDir(ActiveView, 0)
         VDir(1) = ViewDir(ActiveView, 1)
         VDir(2) = ViewDir(ActiveView, 2)
         AVPort1.Direction = VDir
        '4.2
        'ZoomIn
         ZCPt(0) = ViewCtr(ActiveView, 0)
         ZCPt(1) = ViewCtr(ActiveView, 1)
         ZCPt(2) = ViewCtr(ActiveView, 2)
         ZoomCenter ZCPt, ZWid
        'ThisDrawing.Regen acActiveViewport
       Next
     
     End Sub

    'TestRoutine02 / IsoViews / 'ViewPoint-Vertical < +90°

This discussion has been closed.