Viewports and Dimension Scales

Option Explicit
Dim acadApp As Object
Dim acadDoc As Object
Dim ACLayout As AcadLayout
Dim bar_height As Double
Dim bar_hole_dia As Double
Dim basepoint(0 To 2) As Double
Dim center(0 To 2) As Double
Dim circleObj As AcadCircle
Dim definingPoint(0 To 2) As Double
Dim dimObjDiametric As AcadDimDiametric
Dim dimObjOrdinate As AcadDimOrdinate
Dim DimScaleViewPort As Double
Dim dt As String
Dim holepnt(0 To 2) As Double
Dim insertionPoint(0 To 2) As Double
Dim leaderEndPoint(0 To 2) As Double
Dim leaderlength As Double
Dim maxExtBlock1 As Variant
Dim minExtBlock1 As Variant
Dim objblock As AcadBlock
Dim objBlockRef As AcadBlockReference
Dim objlayer As AcadLayer
Dim oEnt2 As AcadEntity
Dim plineObjLW_a As AcadLWPolyline
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim pviewportObj As AcadPViewport
Dim TRfabLen As Double
Dim vertices() As Double
Dim vpHeight As Double
Dim vpWidth As Double
Dim objdrawingobject As AcadEntity
Dim objss As AcadSelectionSet
Dim iblockname As String

Sub Example_ScaleDimensionObjects()

    'retreive the active autocad document
    Set acadApp = GetObject(, "AutoCAD.Application")
    Set acadDoc = acadApp.ActiveDocument
    
    'remove all drawn objects and layout 605
    On Error Resume Next
    acadDoc.Layouts.Item("605").Delete
    On Error GoTo 0
    acadDoc.ActiveSpace = acModelSpace
    Set objss = acadDoc.SelectionSets.Add("ToErase1")
    objss.Select acSelectionSetAll
    On Error Resume Next
    For Each objdrawingobject In objss
        objdrawingobject.Erase
    Next
    objss.Delete
    acadDoc.Regen acAllViewports
    
    'create an object block
    dt = Format(CStr(Now), "mm-dd_hh-mm-ss")
    iblockname = "TRbarBlock" & dt
    basepoint(0) = 0: basepoint(1) = 0
    Set objblock = acadDoc.Blocks.Add(basepoint, iblockname)
    
    'create layers
    Set objlayer = acadDoc.Layers.Add("HMT Text And Dimensions")
    objlayer.Color = 6
    Set objlayer = acadDoc.Layers.Add("HMT Object Solid")
    objlayer.Color = 4
    Set objlayer = acadDoc.Layers.Add("viewport")
    objlayer.Color = 3
    acadDoc.ActiveLayer = acadDoc.Layers("HMT Text and Dimensions")
    
    'create the rectangle
    bar_height = 36
    TRfabLen = 48
    ReDim vertices(7)
    vertices(0) = 0: vertices(1) = 0
    vertices(2) = TRfabLen: vertices(3) = 0
    vertices(4) = TRfabLen: vertices(5) = -bar_height
    vertices(6) = 0: vertices(7) = -bar_height
    Set plineObjLW_a = objblock.AddLightWeightPolyline(vertices)
    plineObjLW_a.Closed = True
    plineObjLW_a.Layer = "HMT Object Solid"
    
    'add the ordinate dimesnions
    definingPoint(0) = 0#: definingPoint(1) = 0#
    leaderEndPoint(0) = 0#: leaderEndPoint(1) = 2#
    Set dimObjOrdinate = objblock.AddDimOrdinate(definingPoint, leaderEndPoint, 5#)
    definingPoint(0) = 0#: definingPoint(1) = 0#
    leaderEndPoint(0) = -2#: leaderEndPoint(1) = 0#
    Set dimObjOrdinate = objblock.AddDimOrdinate(definingPoint, leaderEndPoint, 0)
    definingPoint(0) = 0#: definingPoint(1) = -bar_height
    leaderEndPoint(0) = -2#: leaderEndPoint(1) = -bar_height
    Set dimObjOrdinate = objblock.AddDimOrdinate(definingPoint, leaderEndPoint, 0)
    definingPoint(0) = TRfabLen: definingPoint(1) = 0#
    leaderEndPoint(0) = TRfabLen: leaderEndPoint(1) = 2
    Set dimObjOrdinate = objblock.AddDimOrdinate(definingPoint, leaderEndPoint, 5#)

    'add the center hole
    holepnt(0) = TRfabLen / 2
    holepnt(1) = -bar_height / 2
    bar_hole_dia = 5
    Set circleObj = objblock.AddCircle(holepnt, bar_hole_dia / 2)
    circleObj.Layer = "HMT Object Solid"
    
    'add the diametric dimension
    point1(0) = -0.342 * bar_hole_dia / 2: point1(1) = 0.939 * bar_hole_dia / 2
    point2(0) = 0.342 * bar_hole_dia / 2: point2(1) = -0.939 * bar_hole_dia / 2
    leaderlength = 5#
    Set dimObjDiametric = objblock.AddDimDiametric(point2, point1, leaderlength)
    dimObjDiametric.TextOverride = "<>\PHOLE THRU\P(1 PLACE)"
    point1(0) = 0: point1(1) = 0
    dimObjDiametric.Move point1, holepnt
    
    'insert the block reference and find the extents of the block
    insertionPoint(0) = -50:  insertionPoint(1) = 50
    Set objBlockRef = acadDoc.ModelSpace.InsertBlock(insertionPoint, iblockname, 1, 1, 1, 0)
    objBlockRef.GetBoundingBox minExtBlock1, maxExtBlock1
    minExtBlock1(0) = minExtBlock1(0) - 25
    maxExtBlock1(0) = maxExtBlock1(0) + 25
    
    'add the layout 605
    Set ACLayout = acadDoc.Layouts.Add(605)
    acadDoc.ActiveLayout = ACLayout
    
    'add the viewport
    center(0) = 8.32: center(1) = 5.32
    vpWidth = 16.5
    vpHeight = 10.5
    Set pviewportObj = acadDoc.PaperSpace.AddPViewport(center, vpWidth, vpHeight)
    pviewportObj.Layer = "viewport"
    pviewportObj.Display True
    acadDoc.MSpace = True
    acadDoc.Application.ZoomWindow minExtBlock1, maxExtBlock1
    acadDoc.MSpace = False
    pviewportObj.DisplayLocked = True
    acadDoc.Regen acAllViewports
    
    'scale the dimensions to match the viewport
    DimScaleViewPort = 1 / pviewportObj.CustomScale
    For Each oEnt2 In acadDoc.Blocks(iblockname)
        oEnt2.scalefactor = DimScaleViewPort
    Next oEnt2
    objBlockRef.Explode
    objBlockRef.Delete
    acadDoc.Application.ZoomExtents
    
End Sub