圆范数

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