Microstation Mvba TextBorder

Type txtBorder
  gg As Long
  lineWeight As Integer
  color As Long
  level As String
End Type


Public tBorder As txtBorder

' ===============================================================================
Sub textBorder()
  Dim sScanEnumerator As ElementEnumerator
  Dim sElement As element
  Dim gg As Long
  Dim sFence As Fence
  tBorder.lineWeight = 4
  tBorder.color = 16
  tBorder.level = "Border"
  Set sFence = ActiveDesignFile.Fence
  If ActiveModelReference.AnyElementsSelected Or sFence.IsDefined Then
     If ActiveModelReference.AnyElementsSelected Then
        Set sScanEnumerator = ActiveModelReference.GetSelectedElements
     Else
        Set sScanEnumerator = sFence.GetContents
     End If
     ActiveModelReference.UnselectAllElements
     Do While sScanEnumerator.MoveNext
        Set sElement = sScanEnumerator.Current
        If sElement.Type = msdElementTypeText Or sElement.Type = msdElementTypeTextNode Then
           besuTextBorder sElement, tBorder
        End If
     Loop
  Else
     CommandState.StartLocate New classTextBorder
  End If
End Sub

Function besuTextBorder(sElement As element, tBorder As txtBorder)
   gg = UpdateGraphicGroupNumber 'CurrentGraphicGroup
   tBorder.gg = gg
    If sElement.Type = msdElementTypeTextNode Then
       dropElemTN sElement, tBorder
    End If
    If sElement.Type = msdElementTypeText Then
       dropElemT sElement, tBorder
    End If
    sElement.GraphicGroup = tBorder.gg
    sElement.Rewrite
End Function

' ===============================================================================
Function dropElemTN(oEle As element, tBorder As txtBorder)
    ShowStatus ""
    On Error GoTo NoElement
    If oEle.IsDroppableElement Then
        Dim oDE As DroppableElement
        Dim oEE As ElementEnumerator
        Set oDE = oEle
        Set oEE = oDE.Drop
        Do While oEE.MoveNext
            If oEE.Current.Type = msdElementTypeText Then
               dropElemT oEE.Current, tBorder.gg
            End If
        Loop
    End If
    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function

' ===============================================================================
Function dropElemT(oEle As element, tBorder As txtBorder)
    ShowStatus ""
    On Error GoTo NoElement
    If oEle.IsDroppableElement Then
        Dim oNew As element
        Dim oDE As DroppableElement
        Dim oEE As ElementEnumerator
        Set oDE = oEle
        Set oEE = oDE.Drop
        Do While oEE.MoveNext
            Set oNew = oEE.Current
            ActiveModelReference.AddElement oNew
            oNew.lineWeight = tBorder.lineWeight
            oNew.color = tBorder.color
            oNew.GraphicGroup = tBorder.gg
            oNew.level = besuLevel(tBorder.level & "_" & oEle.level.Name)
            oNew.Rewrite
            If oNew.IsClosedElement Then
               oNew.AsClosedElement.FillMode = msdFillModeNotFilled
               oNew.Rewrite
            End If
            If oNew.IsCellElement Then
               CellElem oNew.AsCellElement
            End If
        Loop
    End If

    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function

' ===============================================================================
Function CellElem(cEle As CellElement)
  Dim cComponents As ElementEnumerator
  On Error GoTo NoElement
  Set cComponents = cEle.GetSubElements
  Do While cComponents.MoveNext
    Dim cComponent As element
    Set cComponent = cComponents.Current
    If cComponent.IsClosedElement Then
       cComponent.AsClosedElement.FillMode = msdFillModeNotFilled
       cComponent.Rewrite
    End If
  Loop
  'cEle.Rewrite
    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function






' ===============================================================================
Function besuLevel(levname As String) As level
   Set besuLevel = ActiveDesignFile.Levels.Find(levname)
   If besuLevel Is Nothing Then
      CadInputQueue.SendKeyin "level create " & Chr(34) & levname & Chr(34)
      'Set besuLevel = ActiveDesignFile.Levels.Find(levname)
   End If
   Set besuLevel = ActiveDesignFile.Levels.Find(levname)
End Function

class modülüne de alttaki kodlar yazılır. class modülünün ismi önemli

classTextBorder

Option Explicit
Implements ILocateCommandEvents

' ===============================================================================
' DATAPOINT HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Accept(ByVal element As element, point As Point3d, ByVal View As View)
    besuTextBorder element, tBorder
'    CommandState.StartPrimitive New classDrawValve
End Sub

' ===============================================================================
' CLEANUP HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Cleanup()

End Sub

' ===============================================================================
' DYNAMICS HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Dynamics(point As Point3d, _
    ByVal View As View, ByVal DrawMode As MsdDrawingMode)
End Sub

' ===============================================================================
' LOCATE FAILED HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_LocateFailed()
    CommandState.StartLocate New classTextBorder
End Sub

' ===============================================================================
' LOCATE FILTER - lines only
' ===============================================================================
Private Sub ILocateCommandEvents_LocateFilter(ByVal element As element, _
    point As Point3d, Accepted As Boolean)
    Accepted = False
    If (element.IsTextElement) Or (element.IsTextNodeElement) Then
            Accepted = True
    End If
End Sub

' ===============================================================================
' RESET HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_LocateReset()
    CommandState.StartLocate New classTextBorder
'    CommandState.StartDefaultCommand
End Sub

' ===============================================================================
' LOCATE INITIALIZATION
' ===============================================================================
Private Sub ILocateCommandEvents_Start()
    Dim lc As LocateCriteria
    Set lc = CommandState.CreateLocateCriteria(False)
    CommandState.SetLocateCriteria lc
    CommandState.EnableAccuSnap
    ShowCommand "Place Component"
    ShowPrompt "Select Text or TextNode"
End Sub

kodları kod projemize ekledikten sonra
 vba run textBorder 

ile programı çalıştırıyoruz.