圆范数

Function InsertBlockref(Space As AcadBlock, insPt As Variant, sName As String, Optional Sc As Double = 1, Optional Rot As Double = 0) As AcadBlockReference
    Dim oBref As AcadBlockReference
    Dim Zero(2) As Double
    Dim N(2) As Double, oUcs As AcadUCS
    Dim Att
    
    Set oBref = Space.InsertBlock(Zero, sName, Sc, Sc, Sc, Rot)
    If ThisDrawing.GetVariable("Worlducs") = 1 Then
        Set InsertBlockref = oBref
        Exit Function
    End If
    
    N(2) = 1
    oBref.Normal = N
    If oBref.HasAttributes Then
        For Each Att In oBref.GetAttributes
            Att.Normal = N
        Next Att
    End If
    Set oUcs = GetActiveUcs
    oBref.TransformBy oUcs.GetUCSMatrix
    oBref.InsertionPoint = insPt
    Set InsertBlockref = oBref
End Function

Function GetActiveUcs() As AcadUCS
    Dim Origin
    Dim Xaxis
    Dim Yaxis
    Dim strNm As String, sUcs As String
    sUcs = ThisDrawing.GetVariable("UCSNAME")
    If sUcs = "" Then
        ' Current UCS is not saved so get the data and save it
        'A ucs is saved when a user makes and saves one or
        ' a user clicks on an isoview button
        With ThisDrawing
            If .GetVariable("WORLDUCS") = 1 Then
                Xaxis = Zero: Yaxis = Zero
                Xaxis(0) = 1: Yaxis(1) = 1
                Set GetActiveUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, "World")
                Exit Function
            End If
            Origin = .GetVariable("UCSORG")
            Xaxis = .GetVariable("UCSXDIR")
            Yaxis = .GetVariable("UCSYDIR")
            strNm = "Active"
        End With
        Set GetActiveUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, strNm)
        'Changing the origin later stops the error message
        '-2145320930   UCS X axis and Y axis are not perpendicular
        GetActiveUcs.Origin = Origin
        ThisDrawing.ActiveUCS = GetActiveUcs
    Else
        Select Case sUcs
            Case "*TOP*", "TOP"
                Set GetActiveUcs = SetOrthoUCS("Top")
            Case "*BOTTOM*"
                Set GetActiveUcs = SetOrthoUCS("Bottom")
            Case "*LEFT*"
                Set GetActiveUcs = SetOrthoUCS("Left")
            Case "*RIGHT*"
                Set GetActiveUcs = SetOrthoUCS("Right")
            Case "*FRONT*"
                Set GetActiveUcs = SetOrthoUCS("Front")
            Case "*BACK*"
                Set GetActiveUcs = SetOrthoUCS("Back")
            Case Else
                Set GetActiveUcs = ThisDrawing.ActiveUCS  'current UCS is saved
            End Select
    End If
End Function

Public Function SetOrthoUCS(Optional strUcs As String = "Top") As AcadUCS
    Dim dOrigin(2) As Double
    Dim dXaxisPnt(2) As Double
    Dim dYaxisPnt(2) As Double
    'all the ucs' will originate from 0,0,0 as per the behavior in acad
    Select Case strUcs
        Case "Top"
            dXaxisPnt(0) = 1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0
            dYaxisPnt(0) = 0: dYaxisPnt(1) = 1: dYaxisPnt(2) = 0
       
        Case "Bottom"
            dXaxisPnt(0) = -1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0
            dYaxisPnt(0) = 0: dYaxisPnt(1) = 1: dYaxisPnt(2) = 0
        
        Case "Right"
            dXaxisPnt(0) = 0: dXaxisPnt(1) = 1: dXaxisPnt(2) = 0
            dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1
        
    
        Case "Left"
            dXaxisPnt(0) = 0: dXaxisPnt(1) = -1: dXaxisPnt(2) = 0
            dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1
        
    
        Case "Front"
            dXaxisPnt(0) = 1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0
            dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1
    
      
        Case "Back"
            dXaxisPnt(0) = -1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0
            dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1
            
        Case Else
            Exit Function
    End Select
    Set SetOrthoUCS = ThisDrawing.UserCoordinateSystems.Add(dOrigin, dXaxisPnt, dYaxisPnt, strUcs)
    ThisDrawing.ActiveUCS = SetOrthoUCS
End Function