TPE

[e-mail]

---

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

چنین لیستی را در نظر داریم:

Text [tab] Text
Text [tab] Text
Text [tab] Text

یا مثلا این لیست:

Text [tab] Text [tab] Text [tab] Text
Text [tab] Text [tab] Text [tab] Text
Text [tab] Text [tab] Text [tab] Text

برای اضافه کردن خطوط راهنمای Leader به متن جدول بندی شده، متن را انتخاب می کنیم و این ماکرو را اجرا می کنیم:

Sub LeaderLines()

    Dim oSh As Shape
    Dim oRng As TextRange
    Dim oSld As Slide
    Dim x As Long
    Dim oLine As Shape
    Dim TabInstance As Long
    Dim LineCounter As Long

    Set oSh = ActiveWindow.Selection.ShapeRange(1)
    Set oRng = oSh.TextFrame.TextRange
    Set oSld = oSh.Parent

    With oRng
        For LineCounter = 1 To .Lines.Count
            With .Lines(LineCounter)
                TabInstance = 0
                For x = 1 To .Characters.Count
                    If .Characters(x) = vbTab Then
                        TabInstance = TabInstance + 1
                        If IsOdd(TabInstance) Then
                            With .Characters(x)
                                Set oLine = oSld.Shapes.AddLine(.BoundLeft, _
                                .BoundTop + .Boundheight, _
                                .BoundLeft + .Boundwidth, _
                                .BoundTop + .Boundheight)
                                With oLine
                                    .Fill.Transparency = 0#
                                    .Line.Weight = 3#
                                    .Line.DashStyle = msoLineRoundDot
                                End With
                            End With
                        End If
                    End If
                Next
            End With
        Next    ' line
    End With

End Sub

Function IsOdd(lInput As Long) As Boolean
    If lInput \ 2 = lInput / 2 Then
        IsOdd = False
    Else
        IsOdd = True
    End If
End Function

---