Add background for ALL Geopak labels from macro that only allows single selection

I have code made by Chuck Rheault that allows you to select individual Geopak labels to toggle background.

Would it be possible to convert this to add backgrounds to ALL the Geopak labels in a model so I do not have to select them all individually?

Geopak V8i (SS10) 08.11.09.918

Microstation (SS10) 08.11.09.919

TextBackground.mvba

Parents
  • Would it be possible to convert this to add backgrounds to all the Geopak labels in a file model
    1. Create a model scanner that gets all labels
    2. For each label
      • Call the function to toggle the label background
      • Rewrite the label
    I have code made by Chuck Rheault

    That's a name from the past...

     
    Regards, Jon Summers
    LA Solutions

  • I am an absolute novice at this, and looks like I need to spend some time with it

    Here's an example that uses VBA to scan for a cell.

     
    Regards, Jon Summers
    LA Solutions

  • Here's what I am confused by, the process to select the element looks like it is at the bottom, but is told to run first by the first line in the code?

    Example 2 here looks like it does what I want by scanning for text.

    Would I be correct by extracting the scan from the example, and replacing all "ILocateCommandEvents" with it? Am I in the ballpark in my amateur thinking? I understand the logic:

    1. Scan for text that does not already have a background
    2. Store selected text
    3. Perform text background code on the stored text
    4. End process

    Implements ILocateCommandEvents
    Private Function ApplyTextBackground(el As element, marginX As Double, marginY As Double) As Boolean
        Dim border As Point2d
        ' remove background if already exists
        If el.AsTextElement.TextStyle.BorderAndBackgroundVisible = True Then
            el.Redraw msdDrawingModeErase
            el.AsTextElement.TextStyle.BorderAndBackgroundVisible = False
        Else
            border.X = marginX * 0.125
            border.Y = marginY * 0.48
            el.AsTextElement.TextStyle.BackgroundFillColor = 255
            el.AsTextElement.TextStyle.BorderColor = 255
            el.AsTextElement.TextStyle.BorderMargins = border
            el.AsTextElement.TextStyle.BorderAndBackgroundVisible = True
        End If
    
        el.Redraw
        el.Rewrite
    
    End Function
    
    Private Sub Class_Initialize()
    
    End Sub
    
    Private Sub ILocateCommandEvents_Accept(ByVal element As element, _
            point As Point3d, ByVal view As view)
    
        ' base border on text size for TextElements
        If element.Type = msdElementTypeText Then
            ApplyTextBackground element, element.AsTextElement.TextStyle.Width, _
                                    element.AsTextElement.TextStyle.Height
        ' base border on line spacing for TextNodeElements
        ElseIf element.Type = msdElementTypeTextNode Then
            Dim ee As ElementEnumerator
    
            Set ee = element.AsTextNodeElement.GetSubElements
            Do While ee.MoveNext
                ApplyTextBackground ee.Current, element.AsTextNodeElement.LineSpacing, _
                                            element.AsTextNodeElement.LineSpacing
            Loop
    
        ElseIf element.Type = msdElementTypeCellHeader Then
            Dim eee As ElementEnumerator
    
            Set ee = element.AsCellElement.GetSubElements
            Do While ee.MoveNext
                If ee.Current.Type = msdElementTypeText Then
                    ApplyTextBackground ee.Current, ee.Current.AsTextElement.TextStyle.Width, _
                                            ee.Current.AsTextElement.TextStyle.Height
                ElseIf ee.Current.Type = msdElementTypeTextNode Then
                    Set eee = ee.Current.AsTextNodeElement.GetSubElements
                    Do While eee.MoveNext
                        If eee.Current.Type = msdElementTypeText Then
                            ApplyTextBackground eee.Current, ee.Current.AsTextNodeElement.LineSpacing, _
                                            ee.Current.AsTextNodeElement.LineSpacing
                        End If
                    Loop
                End If
            Loop
    
        End If
        element.Redraw msdDrawingModeNormal
        view.Redraw
        CommandState.StartLocate New clsSetTextBackground
    
    End Sub
    
    Private Sub ILocateCommandEvents_Cleanup()
    
    End Sub
    
    Private Sub ILocateCommandEvents_Dynamics(point As Point3d, ByVal view As view, _
            ByVal DrawMode As MsdDrawingMode)
    
    End Sub
    
    Private Sub ILocateCommandEvents_LocateFailed()
    
    End Sub
    
    Private Sub ILocateCommandEvents_LocateFilter(ByVal element As element, _
                    point As Point3d, Accepted As Boolean)
    
        ShowPrompt "Accept/Reject"
        Accepted = True
    End Sub
    
    Private Sub ILocateCommandEvents_LocateReset()
    
    End Sub
    Private Sub ILocateCommandEvents_Start()
        Dim lc As LocateCriteria
    
        Set lc = CommandState.CreateLocateCriteria(True)
    
        ShowCommand "Apply Text Background"
        ShowPrompt "Identify Text"
    
        lc.ExcludeAllTypes
        lc.IncludeType msdElementTypeText
        lc.IncludeType msdElementTypeCellHeader
        'lc.IncludeType msdElementTypeTextNode
    
        CommandState.SetLocateCriteria lc
        CommandState.EnableAccuSnap
    
    End Sub
    
    

  • the process to select the element looks like it is at the bottom, but is told to run first by the first line in the code?

    That class Implements ILocateCommandEvents. ILocateCommandEvents is a state machine. The code executes according to its current state, which changes as you locate/accept/change an element.

    One way to see what is going on is to add some debug diagnostics to the code.  Then you can see what happens and when...

    Private Sub ILocateCommandEvents_LocateFilter(ByVal element As element, _
                    point As Point3d, Accepted As Boolean)
    
        ShowPrompt "Accept/Reject"
        Accepted = True
        Debug.Print "ILocateCommandEvents_LocateFilter"
    End Sub

    Private Sub ILocateCommandEvents_Start()
        Dim lc As LocateCriteria
    
        Set lc = CommandState.CreateLocateCriteria(True)
    
        ShowCommand "Apply Text Background"
        ShowPrompt "Identify Text"
    
        lc.ExcludeAllTypes
        lc.IncludeType msdElementTypeText
        lc.IncludeType msdElementTypeCellHeader
        'lc.IncludeType msdElementTypeTextNode
    
        CommandState.SetLocateCriteria lc
        CommandState.EnableAccuSnap
        Debug.Print "ILocateCommandEvents_Start"
    
    End Sub

    The debug messages are shown in VBA's Immediate Window.

     
    Regards, Jon Summers
    LA Solutions

Reply
  • the process to select the element looks like it is at the bottom, but is told to run first by the first line in the code?

    That class Implements ILocateCommandEvents. ILocateCommandEvents is a state machine. The code executes according to its current state, which changes as you locate/accept/change an element.

    One way to see what is going on is to add some debug diagnostics to the code.  Then you can see what happens and when...

    Private Sub ILocateCommandEvents_LocateFilter(ByVal element As element, _
                    point As Point3d, Accepted As Boolean)
    
        ShowPrompt "Accept/Reject"
        Accepted = True
        Debug.Print "ILocateCommandEvents_LocateFilter"
    End Sub

    Private Sub ILocateCommandEvents_Start()
        Dim lc As LocateCriteria
    
        Set lc = CommandState.CreateLocateCriteria(True)
    
        ShowCommand "Apply Text Background"
        ShowPrompt "Identify Text"
    
        lc.ExcludeAllTypes
        lc.IncludeType msdElementTypeText
        lc.IncludeType msdElementTypeCellHeader
        'lc.IncludeType msdElementTypeTextNode
    
        CommandState.SetLocateCriteria lc
        CommandState.EnableAccuSnap
        Debug.Print "ILocateCommandEvents_Start"
    
    End Sub

    The debug messages are shown in VBA's Immediate Window.

     
    Regards, Jon Summers
    LA Solutions

Children
No Data