Периметр линий разных цветов

mataba

mataba

Участник
Топикстартер
Сообщения
11
Реакции
0
Всем привет . Уважаемые знатоки - помогите написать скрипт. Смысл такой чтобы он считал периметр линий определенного цвета.... и выводил в диалоговом окне сообщение с инфой - фото прикрепил.
 

Вложения

  • ывафыуывыфыв.JPG
    ывафыуывыфыв.JPG
    33.3 КБ · Просм.: 387
В диалоговом окне чертовски затруднительно линию нарисовать будет
 
форма тоже подходит
 
Чего куда подходит?
 
достаточно MsgBox с текстовой инфой....
 
mataba сказал(а):
помогите написать скрипт.
Нажмите, чтобы раскрыть...
оно уже есть - правда, корабль с двухступенчатым двигателем
1. Часть из wx_TOOLS - есть тут
wx.selectSameFillColor, wx.selectSameFillAndOutline, wx.selectSameOutline, wx.selectSameDialog - selects ungroupped shapes with same fill/outline colors. Enable keyboard ScrollLock led to specify sensitivity (negative values allow selection inside groups)
Нажмите, чтобы раскрыть...
этим можно выделив линию нужного цвета, найти и выделить все подобные остальные

2. опять же, часть другого макроса - тема тут
понадобится только функционал определения периметра

вырезать, добавить соль, перец, запекать 5 минут нужное и посадить на одну кнопку
 
Для выделенных кривых
Код: 
Sub Macro1()
    ActiveDocument.Unit = cdrMillimeter
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    Dim s As Shape
    Dim iCount As Integer
    Dim flag As Boolean
    Dim arrColor() As Variant
    Dim Result As String
    iCount = 1
    If OrigSelection.Count > 0 Then
        For Each s In OrigSelection
            flag = False
            If iCount = 1 Then
                ReDim arrColor(2, 1)
                arrColor(1, 1) = s.Outline.Color.HexValue
                arrColor(2, 1) = s.Curve.Length
            Else
                For i = 1 To UBound(arrColor, 2)
                    If arrColor(1, i) = s.Outline.Color.HexValue Then
                        arrColor(2, 1) = arrColor(2, 1) + s.Curve.Length
                        flag = True
                    End If
                Next i
                If flag = False Then
                    t = UBound(arrColor, 2) + 1
                    ReDim Preserve arrColor(2, t)
                    arrColor(1, t) = s.Outline.Color.HexValue
                    arrColor(2, t) = s.Curve.Length
                End If
            End If
            iCount = iCount + 1
        Next s
    End If
    For i = 1 To UBound(arrColor, 2)
        Result = Result & " " & arrColor(1, i) & " " & arrColor(2, i) & "mm" & Chr(13)
    Next i
    MsgBox Result
End Sub
 
Последнее редактирование:
  • Спасибо
Реакции: mataba
Слгласен, делал на кривых.
Код: 
Sub Macro1()
    ActiveDocument.Unit = cdrMillimeter
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    Dim s As Shape
    Dim iCount As Integer
    Dim flag As Boolean
    Dim arrColor() As Variant
    Dim Result As String
    iCount = 1
    If OrigSelection.Count > 0 Then
        For Each s In OrigSelection
            flag = False
            If iCount = 1 Then
                ReDim arrColor(2, 1)
                arrColor(1, 1) = s.Outline.Color.HexValue
                arrColor(2, 1) = s.DisplayCurve.Length
            Else
                For i = 1 To UBound(arrColor, 2)
                    If arrColor(1, i) = s.Outline.Color.HexValue Then
                        arrColor(2, 1) = arrColor(2, 1) + s.DisplayCurve.Length
                        flag = True
                    End If
                Next i
                If flag = False Then
                    t = UBound(arrColor, 2) + 1
                    ReDim Preserve arrColor(2, t)
                    arrColor(1, t) = s.Outline.Color.HexValue
                    arrColor(2, t) = s.DisplayCurve.Length
                End If
            End If
            iCount = iCount + 1
        Next s
    End If
    For i = 1 To UBound(arrColor, 2)
        Result = Result & " " & arrColor(1, i) & " " & arrColor(2, i) & "mm" & Chr(13)
    Next i
    MsgBox Result
End Sub
 
  • Спасибо
Реакции: mataba
на текущей странице
по выделенному объекту найдет все объекты с таким же цветом контура
включая объекты в группах и поверклипах
и выдаст по завершению мессиджбокс с периметром найденных объектов в мм



Код: 
Sub Go()
'  cut and simplified by dastin from wx_Tools © wOOxOOm
   Dim sr2 As ShapeRange, sh As Shape, clr As New Color
   Dim OutlineColor As New Color, iPcDepthMode&
   Dim found As New ShapeRange, s$
   Dim ShapeType&, OutlineType&, passOutline%

   If ActiveShape Is Nothing Then Beep: Exit Sub
  
   ShapeType = ActiveShape.Type: OutlineType = -1
   Select Case ShapeType
      Case cdrCurveShape, 21, cdrEllipseShape, 26, _
           cdrPolygonShape, cdrRectangleShape, cdrTextShape 'cdrCustomShape=21, cdrPerfectShape=26
          
            OutlineType = ActiveShape.Outline.Type
            If OutlineType <> cdrNoOutline Then
               OutlineColor.CopyAssign ActiveShape.Outline.Color
               If diff > 0 Then OutlineColor.ConvertToCMYK
            End If
   End Select
  
   On Error Resume Next

      Set sr2 = ActivePage.FindShapes
  
   Err.Clear
    ActiveDocument.ClearSelection
    sr2.AddRange findPC("", -1)
    
For Each sh In sr2
      Select Case sh.Type
      Case cdrCurveShape, 21, cdrEllipseShape, 26, _
           cdrPolygonShape, cdrRectangleShape, cdrTextShape 'cdrCustomShape=21, cdrPerfectShape=26
         passOutline = False

         If sh.Outline.Type = OutlineType Then
            Select Case OutlineType
               Case cdrNoOutline
                passOutline = True
               Case cdrOutline
                passOutline = sh.Outline.Color.IsSame(OutlineColor)
            End Select
         End If
         If passOutline Then found.Add sh
      Case Else
         If sh.Type = ShapeType Then found.Add sh
      End Select
   Next sh
   If found Is Nothing _
      Then ActiveDocument.ClearSelection _
      Else: found.CreateSelection

Call GetPerimetr
ExitSub:
   Exit Sub
ErrHandler:
   MsgBox "Unexpected error occured: " & Err.Description & vbCrLf & Err.Source, vbCritical
   Resume ExitSub
End Sub

Function findPC(q As String, Optional LngLevel As Long) As ShapeRange
    '"findPC" Copyright © Shellby Moor
    'Set lngLevel to:
    '-1 to get all Powerclipped shapes only regardless of how many levels deep they go..
    '0 or leave blank to get all shapes, as you have it.
    '1 Plus to get shapes based on what level deep they are powerclipped.
    'Example: Set to 2 to get shapes that are 2 levels deep Powerclipped.
    Dim srPowerClipped As New ShapeRange, srJustClipped As New ShapeRange, s As Shape
    Dim sr As ShapeRange, srAll As New ShapeRange
    Dim bFound As Boolean, i&
    bFound = False

    If ActiveSelection.Shapes.Count = 0 Then
        Set sr = ActivePage.Shapes.FindShapes()
    Else
        Set sr = ActiveSelection.Shapes.FindShapes()
    End If
    i = 0
    Do
        bFound = False
        For Each s In sr.Shapes.FindShapes(Query:="!@com.powerclip.IsNull")
            srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
        Next s
        If srPowerClipped.Count > 0 Then bFound = True: i = i + 1
        If i = LngLevel And bFound Then
            Set findPC = srPowerClipped
            Exit Function
        End If
                    
        srAll.AddRange sr
        sr.RemoveAll
        sr.AddRange srPowerClipped
        If LngLevel = -1 Then srJustClipped.AddRange srPowerClipped
        srPowerClipped.RemoveAll
    Loop Until sr.Count = 0
    
    If LngLevel = -1 Then
        Set sr = srJustClipped
    ElseIf bFound Or LngLevel = 0 Then
        Set sr = srAll
    Else
        Set sr = New ShapeRange
    End If
    Set findPC = New ShapeRange
    If q = "" Then
        Set findPC = sr
    Else
        For Each s In sr.Shapes.FindShapes(Query:=q)
            findPC.Add s
        Next s
    End If
End Function

Private Sub GetPerimetr()
'==================================================================
' "PerimeterModule" Copyright © Nicholas Wilkinson 2001
' Version 1.0, 2001-11.
' small add dastin ©
'==================================================================
    Dim doc As Document, old_units As Long, sDupShape As Shape
    Dim length As String, per As String, edleng As String, leng As Double, shape_count As Long
    shape_count = ActiveSelection.Shapes.Count
    If shape_count > 0 Then
        'Set the document units to horizontal ruler units
        Set doc = ActiveDocument
        doc.BeginCommandGroup "IsoCalc.com's Perimeter temporary shapes"
        old_units = doc.Unit
        doc.Unit = doc.Rulers.HUnits
        'Get the length of the shape or shapes and tidy up
        ActiveSelection.Duplicate
        ActiveSelection.UngroupAll
        Set sDupShape = ActiveSelection.Combine
        length = (sDupShape.Curve.length * doc.WorldScale)
        On Error Resume Next
        doc.EndCommandGroup
        doc.Undo
'        doc.Unit = old_units
        leng = CDbl(length)
        edleng = Choose(doc.Unit + 1, " tenth-microns", _
                    " inches", " feet", " mm", " cm", " pixels", " miles", " m", _
                    " km", " didots", " Agate", " yds", " pica", " cicero", " pt", _
                    " Q", " H")
        per = FormatNumber(leng, 0, , , vbTrue) & edleng
        MsgBox per
    End If
End Sub

1570517673160.png
 
  • Спасибо
Реакции: izrukvruki и mataba
Вышеприведенный код собранный в GMS (Corel X7) - в ресурсах
 
Для ответа нужно войти/зарегистрироваться
Верх Низ