AutoCAD - Block Mirror Text

[Biolightant]

Merhaba,

AutoCAD de bir Block u Mirror lama yapınca
Block içinde Text varsa TERSTEN gözükür ( mirrortext=0 olmasına rağmen )
buna çözüm önerisi olarak VBA da makro ürettim.

HATALI GÖRÜNTÜYE ÖRNEK :

ÜRETTİĞİM ÇÖZÜM

Not: AutoCAD 2013 de ürettim ve test ettim kodları
elinde başka sürüm AutoCAD olan varsa test edip sonucu bildirirse sevinirim.

Option Explicit

Sub TextInsideMirroredBlock()
' Biolight 2024 - Eppur Si Muove - biolightant@gmail.com
'
' Block içinde yazı varsa (Text, Dimension a bağlı text)
' MIRRTEXT = 0 olmasına rağmen
' Block Mirror (aynalama) yapılınca yazılar TERSTEN gözükür
' Bu hatayı gidermek için bir çözüm üretir
'
    Dim objEnt As AcadObject
    Dim emptyPt(0 To 2) As Double
    Dim point1, point2 As Variant

    On Error Resume Next
TekrarSec:
    ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Düzenlenecek Block seçiniz: "
   
    If Err <> 0 Then
        ' esc, space veya enter tıklanırsa sonlandır
        If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
            ThisDrawing.SendCommand Chr(3)
            Err.Clear
            Exit Sub
        Else
            ThisDrawing.Utility.Prompt "Block değil...!" & vbCrLf
            Err.Clear
            GoTo TekrarSec
        End If
    End If

    If objEnt.ObjectName = "AcDbBlockReference" Then
   
    ' MIRRTEXT değişkenini 0 olarak ayarla
    ThisDrawing.SetVariable "MIRRTEXT", 0

    ' Block un kapladığı alan koordinatları
    objEnt.GetBoundingBox point1, point2

    objEnt.Explode ' Blok u patlat ( MIRRTEXT=0 dan dolayı yazılar düzeldi ama block parçalandı )
    objEnt.Delete ' Mevcut bloğu sil
   
    ' Group u oluşturacak objeler : Patlatılan block un kapladığı alan koordinatları için de
    ' Crossing ile bu alanı belirle ve objeleri seç ( x.x,y.y,z.z )
    ThisDrawing.SendCommand "GROUP CROSSING" & vbCr & _
    Replace(point1(0), ",", ".") & "," & Replace(point1(1), ",", ".") & ",0.0" & vbCr & _
    Replace(point2(0), ",", ".") & "," & Replace(point2(1), ",", ".") & ",0.0" & vbCr & vbCr
   
    ThisDrawing.Utility.Prompt "Yeni bir " ' TekrarSec ile "Yeni bir Düzenlenecek Block seçiniz: " gözükecek
   
    Else
        ThisDrawing.Utility.Prompt "Block değil...!" & vbCrLf
        Err.Clear
        GoTo TekrarSec
    End If

GoTo TekrarSec

End Sub