Bemassung in Pixel

[koter]

Hallo Mike,

...Leider  - zumindest sehe und finde ich es nicht - gibt es keine Möglichkeit die Einheiten auf Pixel einzustellen.
aktuell behelfen wir uns damit, die Einheiten auszublenden und dann die Werte manuell einzutragen.
Das ist müßig und auch nervend...

eine Möglichkeit die Einheiten auf Pixel einzustellen kenne ich nicht.
Man könnte höchstens die manuelle Arbeit automatisieren:



Alle von Miss Marple aufgezählten Einschränkungen müssen natürlich beachtet werden!

Folgender Code bearbeitet horizontale und vertikale Bemaßungen (und nur diese):

Code:

Sub PixDim()
   Dim s As Shape, ts As Shape, tsNeu As Shape, B As Shape
   Dim Einheit As String
   Dim x As Double, y As Double, Width As Double, Height As Double
   Dim Abstand As Integer
   Dim c As New Color
   
   c.RGBAssign 255, 255, 255
   ActiveDocument.Unit = cdrPixel
   
   Einheit = "Pxl"
   Abstand = 6
   
   If Einheit <> "" Then Einheit = " " & Einheit
   ActiveDocument.BeginCommandGroup "Pixelmaße"
   Application.Optimization = True
   For Each s In ActiveLayer.FindShapes(Type:=cdrLinearDimensionShape)
       Set ts = s.Dimension.TextShape
       Set tsNeu = s.Dimension.TextShape.CopyToLayer(ActiveLayer)
       If s.Dimension.Linear.Type = cdrDimensionHorizontal Then
           tsNeu.Text.Story = Round(s.SizeWidth, 0) & Einheit
           tsNeu.CenterX = ts.CenterX
       ElseIf s.Dimension.Linear.Type = cdrDimensionVertical Then
           tsNeu.Text.Story = Round(s.SizeHeight, 0) & Einheit
           tsNeu.CenterY = ts.CenterY
       End If
       ts.Fill.ApplyNoFill
       tsNeu.BoundingBox.GetRect x, y, Width, Height
       Set B = ActiveLayer.CreateRectangle2(x - Abstand, y - Abstand, Width + Abstand * 2, Height + Abstand * 2)
       With B
           .Fill.ApplyUniformFill c
           .Outline.SetNoOutline
           .OrderBackOf tsNeu
       End With

       ActiveSelectionRange.Shapes.All.RemoveFromSelection
       s.CreateSelection
       s.Style.GetProperty("dimension").SetProperty "textPlacement", cdrDimensionAboveLine
   Next
   Application.Optimization = False
   ActiveSelectionRange.Shapes.All.RemoveFromSelection
   ActiveDocument.EndCommandGroup
   Application.Refresh
   
End Sub

Gruß

Koter