Как создать блок с именем, начинающимися на "*"?

Option Explicit
'@=========================================@'
'@   Функция создания анонимного блока     @'
'@=========================================@'
Public Function UnBlock(insPnt As Variant, objSelSet As AcadSelectionSet) As AcadBlockReference
  Dim objNewBlock As AcadBlock
  Dim objInsBlk As AcadBlockReference
  Dim objEnt As AcadEntity
  Dim objSpace As AcadBlock
  On Error GoTo ErrHandler
  Set objSpace = GetSpase
  Set objNewBlock = BlockSelSet(objSelSet, _
  insPnt, BlockNameIncrement("UnBlock"))
  Set objInsBlk = objSpace.InsertBlock(insPnt, objNewBlock.Name, 1, 1, 1, 0)
  objNewBlock.Name = "*U"
  Set UnBlock = objInsBlk
  If Not objSelSet Is Nothing Then
    For Each objEnt In objSelSet
      objEnt.Delete
    Next
    objSelSet.Delete
  End If
ExitHere:
  Set objNewBlock = Nothing
  Set objInsBlk = Nothing
  Set objEnt = Nothing
  Set objSpace = Nothing
  Exit Function
ErrHandler:
  MsgBox "ERROR #" & Err.Number & vbCrLf & _
  Err.Description, vbCritical + vbOKOnly, "UnBlock"
  Err.Clear
  Set UnBlock = Nothing
  Resume ExitHere
End Function
Public Sub TEST_UnBlock()
  Dim varPnt As Variant
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objBlockRef As AcadBlockReference
  On Error Resume Next
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = "SelSetForBlock" Then
      objSelSet.Delete
      Exit For
    End If
  Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("SelSetForBlock")
  objSelSet.SelectOnScreen
  With ThisDrawing.Utility
    varPnt = .GetPoint(, vbCr & _
             "Укажите базовую точку блока: ")
  End With
  Set objBlockRef = UnBlock(varPnt, objSelSet)
  MsgBox "Создан анонимный блок с именем" & vbCrLf & objBlockRef.Name, vbInformation + vbOKOnly, "TEST_UnBlock"
End Sub
'@=========================================@'
'@ Определение текущей области документа   @'
'@=========================================@'
Public Function GetSpase() As AcadBlock
    Dim objSpace As AcadBlock
    Dim intTILEMODE As Integer
    Dim intCVPORT As Integer
    On Error GoTo Exit_Here
    intTILEMODE = CInt(ThisDrawing.GetVariable("TILEMODE"))
    If intTILEMODE = 1 Then
      Set objSpace = ThisDrawing.ModelSpace
    Else
      intCVPORT = CInt(ThisDrawing.GetVariable("CVPORT"))
      If intCVPORT = 1 Then
        Set objSpace = ThisDrawing.PaperSpace
      Else
        Set objSpace = ThisDrawing.ModelSpace
      End If
    End If
Exit_Here:
    Set GetSpase = objSpace
    Set objSpace = Nothing
End Function
'@=========================================@'
'@ Функция проверки строки на возможность  @'
'@ использования ее в качестве имени блока @'
'@ Если эта строка уже используется в      @'
'@ качестве имени блока, то функция сгене- @'
'@ рирует на базе заданного новое имя      @'
'@=========================================@'
Public Function BlockNameIncrement(strName As String) As String
  Dim objBlocks As AcadBlocks
  Dim objBlock As AcadBlock
  Dim strValue As String
  Dim intCnt As Integer
  Dim blnFound As Boolean
  On Error GoTo Err_Control
  Set objBlocks = ThisDrawing.Blocks
  strValue = strName
  Do
    For Each objBlock In objBlocks
      If objBlock.Name = strValue Then
        blnFound = True
        intCnt = intCnt + 1
        strValue = strName & intCnt
        Exit For
      Else
        blnFound = False
      End If
    Next objBlock
  Loop Until Not blnFound
  BlockNameIncrement = strValue
Exit_Here:
    Exit Function
Err_Control:
    MsgBox Err.Description
End Function
'@=========================================@'
'@ Функция для создания блока из набора    @'
'@ объектов objSelSet, с именем strName и  @'
'@ с базовой точкой varPnt                 @'
'@=========================================@'
Public Function BlockSelSet(objSelSet As AcadSelectionSet, _
varPnt As Variant, strName As String) As AcadBlock
  Dim objBlks As AcadBlocks
  Dim objTemp As AcadBlock
  Dim objArray() As AcadEntity
  Dim intCnt As Integer
  Set objBlks = ThisDrawing.Blocks
  For intCnt = 0 To objSelSet.Count - 1
    ReDim Preserve objArray(intCnt)
    Set objArray(intCnt) = objSelSet(intCnt)
  Next intCnt
  Set objTemp = objBlks.Add(varPnt, strName)
  ThisDrawing.CopyObjects objArray, objTemp
  Set BlockSelSet = objTemp
ExitHere:
  Set objBlks = Nothing
  Set objTemp = Nothing
  Exit Function
ErrHandler:
  MsgBox "ERROR #" & Err.Number & vbCrLf & Err.Description
  Err.Clear
  Resume ExitHere
End Function