zyzio
Praktyk
Dołączył: 06 Cze 2011 Posty: 90 Skąd: Podkarpacie
|
Wysłany: 24 Sierpień 2021, 09:41 Szybkie wymiarowanie - korekta makra
|
|
|
Witam. Posklejałem makro, które ma automatycznie zwymiarować zaznaczenie w osi x i y.
Na pierwszy rzut oka działa w miarę ok, lecz pojawia się jakiś dziwny problem, gdy zmieniam położenie tekstu na wymiarze osi x, a mianowicie tekst odseparowuje się a linie wymiarowania x i y stają się jednym obiektem. Nie potrafię sobie poradzić z tym problemem, więc z góry dzięki za pomoc.
Kod: | Sub QuickDimensions()
ActiveDocument.unit = cdrMillimeter
Dim srSelection As ShapeRange
Dim x As Double, y As Double, w As Double, h As Double
Dim sPt1 As SnapPoint, sPt2 As SnapPoint
Dim s As Shape
If ActiveSelectionRange.Count = 0 Then
MsgBox "Zaznacz obiekty do zwymiarowania"
Exit Sub
Else
ActiveDocument.BeginCommandGroup "Quick dimensions"
Set srSelection = ActiveSelectionRange
srSelection.GetBoundingBox x, y, w, h
Set sPt1 = CreateSnapPoint(x, y + h + (0.1 * h))
Set sPt2 = CreateSnapPoint(x + w, y + h + (0.1 * h))
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, sPt1, sPt2, True, , , cdrDimensionStyleDecimal, Units:=cdrDimensionUnitMM)
s.Dimension.TextShape.SetPosition sx + w / 2, y + h + (0.2 * h)
s.Dimension.TextShape.Text.Story.Size = w * 0.1
Set sPt1 = CreateSnapPoint(x - (w * 0.1), y)
Set sPt2 = CreateSnapPoint(x - (w * 0.1), y + h)
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, sPt1, sPt2, True, , , cdrDimensionStyleDecimal, Units:=cdrDimensionUnitMM)
s.Dimension.TextShape.SetPosition x - (w * 0.2), y + sx / 2
s.Dimension.TextShape.Text.Story.Size = h * 0.1
End If
ActiveDocument.ClearSelection
srSelection.AddToSelection
ActiveWindow.Refresh
ActiveDocument.EndCommandGroup
End Sub |
Edit:
Widzę, że problem który opisałem występuje w X3, więc to pewnie nie jest wina samego makra, tak czy inaczej pozostawię wątek bo może komuś się przyda, a może ktoś sobie jeszcze ulepszy ten kod. |
|