Угол между World UCS и local UCS

Option Explicit
Public Sub ExportBlocks()
Dim vertlist1() As Double
Dim vertlist3(0 To 2) As Double
Dim objApp As AcadApplication
Dim objDoc As AcadDocument
Dim RowCount As Integer
Dim RowCount1 As Integer
Dim strPrmpt As String
Dim intCnt As Integer
Dim intcnt1 As Integer
Dim objCell As Object
Dim objSheet As Worksheet
Dim wykres_1 As AcadLayer
Dim i As Integer, a As Integer
Dim blok1 As AcadBlock
Dim pktwst(0 To 2) As Double
Dim poli As AcadPolyline
Dim pkt(0 To 29) As Double
Dim nowalin As AcadLine
Dim blokref As AcadBlockReference
Dim blokref1 As AcadBlockReference
Dim zazn As AcadSelectionSet
Dim alayer As String
Dim textst As AcadTextStyle
Dim textObj As AcadText
Dim text1 As String
Dim text2 As String
Dim text3 As String
Dim insPoint1(0 To 2) As Double
Dim insPoint2(0 To 2) As Double
Dim insPoint3(0 To 2) As Double
Dim atr As AcadAttribute
Dim atr1 As AcadAttribute
Dim atr2 As AcadAttribute
Dim atr3 As AcadAttribute
Dim mode As Long
Dim prompt As String
Dim tag As String
Dim prompt1 As String
Dim tag1 As String
Dim prompt2 As String
Dim tag2 As String
Dim prompt3 As String
Dim tag3 As String
Dim height As Double
Dim ap(0 To 2) As Double
Dim ap1(0 To 2) As Double
Dim ap2(0 To 2) As Double
Dim ap3(0 To 2) As Double
Dim sk As Integer
   Dim ucsObj As AcadUCS
    Dim origin(0 To 2) As Double
    Dim xAxisPoint(0 To 2) As Double
    Dim yAxisPoint(0 To 2) As Double
    Dim currUCS As AcadUCS
    Dim kat As Variant
On Error GoTo Err_Control
On Error GoTo Koniec
Set objSheet = ThisWorkbook.Sheets(1)
Set objApp = GetObject(, "AutoCAD.Application")
Set objDoc = objApp.ActiveDocument
With objDoc
            Set currUCS = .UserCoordinateSystems.Add( _
                            .GetVariable("UCSORG"), _
                            .Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
                            .Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
                            "OriginalUCS")
End With
sk = objDoc.Utility.GetInteger("Input scale for block: ")
For Each blok1 In objApp.ActiveDocument.Blocks
      If blok1.Name = "OKU-tabelka" Then GoTo dalej
Next
pktwst(0) = 7.5 * 0.001
pktwst(1) = 3 * 0.001
pktwst(2) = 0
Set textst = objDoc.TextStyles.Add("OKU")
textst.height = 2 * sk * 0.001
textst.Width = 0.7
textst.fontFile = "simplex.shx"
objDoc.ActiveTextStyle = textst
pkt(0) = 0
pkt(1) = 0
pkt(2) = 0
pkt(3) = 14.5 * 0.001
pkt(4) = 0
pkt(5) = 0
pkt(6) = 14.5 * 0.001
pkt(7) = 6 * 0.001
pkt(8) = 0
pkt(9) = 0
pkt(10) = 6 * 0.001
pkt(11) = 0
pkt(12) = 0
pkt(13) = 0
pkt(14) = 0
pkt(15) = 0
pkt(16) = 3 * 0.001
pkt(17) = 0
pkt(18) = 14.5 * 0.001
pkt(19) = 3 * 0.001
pkt(20) = 0
pkt(21) = 14.5 * 0.001
pkt(22) = 6 * 0.001
pkt(23) = 0
pkt(24) = 7.5 * 0.001
pkt(25) = 6 * 0.001
pkt(26) = 0
pkt(27) = 7.5 * 0.001
pkt(28) = 0
pkt(29) = 0
height = 2 * 0.001
mode = acAttributeModeNormal
ap(0) = (pktwst(0) * 1000 - 6.15) * 0.001
ap(1) = (pktwst(1) * 1000 + 0.55) * 0.001
ap(2) = 0
ap1(0) = (pktwst(0) * 1000 + 0.3) * 0.001
ap1(1) = (pktwst(1) * 1000 + 0.55) * 0.001
ap1(2) = 0
ap2(0) = (pktwst(0) * 1000 - 7.15) * 0.001
ap2(1) = (pktwst(1) * 1000 - 2.55) * 0.001
ap2(2) = 0
ap3(0) = (pktwst(0) * 1000 + 1.43) * 0.001
ap3(1) = (pktwst(1) * 1000 - 2.55) * 0.001
ap3(2) = 0
tag = "Nr pala": prompt = "Nr pala"
tag1 = "Przekr. pala": prompt1 = "Przekr. pala"
tag2 = "Rzedna pala": prompt2 = "Rz. pala"
tag3 = "Dlugosc pala": prompt3 = "Dlug. pala"
alayer = "0"
objDoc.ActiveLayer = objDoc.Layers.Item(alayer)
Set blok1 = objDoc.Blocks.Add(pktwst, "OKU-tabelka")
Set poli = blok1.AddPolyline(pkt)
Set atr = blok1.AddAttribute(height, mode, prompt, ap, tag, " ")
atr.ScaleFactor = 0.7
Set atr1 = blok1.AddAttribute(height, mode, prompt1, ap1, tag1, " ")
atr1.ScaleFactor = 0.7
Set atr2 = blok1.AddAttribute(height, mode, prompt2, ap2, tag2, " ")
atr2.ScaleFactor = 0.7
Set atr3 = blok1.AddAttribute(height, mode, prompt3, ap3, tag3, " ")
atr3.ScaleFactor = 0.7
Set blokref = objDoc.ModelSpace.InsertBlock(pktwst, "OKU-tabelka", 1#, 1#, 1#, 0)
blokref.Delete
dalej:
RowCount1 = objSheet.UsedRange.Rows.Count
Dim attvar As Variant
Dim objAtt As AcadAttributeReference
For i = 1 To RowCount1 - 1
vertlist3(0) = objSheet.Cells(i, 4).Value
vertlist3(1) = objSheet.Cells(i, 5).Value
vertlist3(2) = objSheet.Cells(i, 6).Value
Set wykres_1 = objDoc.Layers.Add("OKU-tabelka-pale")
wykres_1.Color = acYellow
objDoc.ActiveLayer = wykres_1
Set blokref1 = objDoc.ModelSpace.InsertBlock(vertlist3, "OKU-tabelka", sk, sk, 1#, 0)
attvar = blokref1.GetAttributes
For a = 0 To UBound(attvar)
Set objAtt = attvar(a)
Select Case UCase(objAtt.TagString)
Case UCase("Nr pala")
objAtt.TextString = objSheet.Cells(i, 2).Value
Case UCase("Przekr. pala")
objAtt.TextString = objSheet.Cells(i, 3).Value
Case UCase("Rzedna pala")
objAtt.TextString = objSheet.Cells(i, 8).Value
Case UCase("Dlugosc pala")
objAtt.TextString = objSheet.Cells(i, 10).Value
End Select
Next a
blokref1.Update
Dim TransMatrix As Variant
TransMatrix = currUCS.GetUCSMatrix()
blokref1.TransformBy (TransMatrix)
blokref1.Update
Next
objDoc.Regen acActiveViewport
Koniec:
Set blokref = Nothing
Exit_Here:
If Not objApp Is Nothing Then
Set objApp = Nothing
Set objDoc = Nothing
End If
Exit Sub
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Sub