---

Fehler_01.jpg

Hallo zusammen!

Hatte mir mal ein kleines Tool geschrieben um Werte in einen Schriftfeldblock zu schreiben.

Dieses hatte ich bislang immer nur auf den Papierbereich angewendet.

Folgende Fehleroutinen möchte ich nun noch einbauen:
- Ist der Modelbereich aktiv, soll eine MsgBox darauf hinweisen
  und das Programm beenden.
- Ist der Papierbereich aktiv und ein Block mit dem
  entsprechenden Namen vorhanden ok, wenn nicht soll auch hier
  eine MsgBox darauf hinweisen und das Programm beenden.

Modul:

Code:

---

Sub User_Dialog()
    StartMask.Show
End Sub

---

UserForm:

Code:

---

Public Sub UserForm_Initialize()
Dim BlockRef As AcadBlockReference
Dim BlockEntity As AcadEntity

On Error GoTo Err_Control

If ThisDrawing.ActiveLayout.Name = "Model" Then
    MsgBox "Dieses Tool ist nur im Papierbereich einsetzbar.", 64, "Hinweis"
    Exit Sub
Else
    For Each BlockEntity In ThisDrawing.ActiveLayout.Block
    If BlockEntity Is Nothing Then Exit Sub
        If TypeOf BlockEntity Is AcadBlockReference Then
            Set BlockRef = BlockEntity
                If BlockRef.Name <> "Schriftfeld" Then
                    MsgBox "Es ist kein Schriftfeld vorhanden." _
                    , 64, "Hinweis"
                    Exit Sub
                Else
                    AttWert = BlockRef.GetAttributes
                End If
        End If
    Next
End If

Err_Control:
If Err Then MsgBox Err.Description

StartMask.TB_BBVH1.Text = UCase(LTrim(AttWert(0).TextString))
StartMask.TB_BBVH2.Text = UCase(LTrim(AttWert(1).TextString))
StartMask.TB_GEZDAM.Text = UCase(LTrim(AttWert(2).TextString))

...
...
End Sub

---

Hiermit bekomme ich allerdings die Meldung "Typen unverträglich".

Könnte mir da jemand weiterhelfen?

Vielen Dank im Voraus.

------------------
Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi Dirk,

Warum machst du denn die Abfrage bezüglich Modell oder Layout nicht bevor du das Formular aufrufst?!
Wo tritt denn der Fehler genau auf?!

Gruß, Carsten

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Carsten!

Danke für den Denkanstoß!

Habe nun alles in das Modul gepackt und nun funktionierts.

Modul:

Code:

---

Sub User_Dialog()
'##--Variablenfestlegung--!!!
Dim sset As AcadSelectionSet
Dim BlockObj As AcadObject
Dim BlockEnt As Variant
Dim minPkt As Variant
Dim maxPkt As Variant

'Dim varAttributes As Variant
'Dim strAttributes As String

Dim BlockData(1) As Variant
Dim BlockType(1) As Integer
BlockType(0) = 0                      'Suche ElemBlockEnttyp
BlockData(0) = "INSERT"                'Blockreferenz
BlockType(1) = 2                      'Suche Attribut, Blockname
BlockData(1) = "Schriftfeld"          'Name des Blockes

'##--per If ... Then die Fehlerroutine steuern--!!!
If ThisDrawing.ActiveSpace = acModelSpace Then
    MsgBox "Dieses Tool ist nur im Papierbereich einsetzbar.", 64, "Hinweis"
    '--Ist der Modelbereich aktiv wird das Programm abgebrochen--!
    Exit Sub
Else
    On Error GoTo 0
    ThisDrawing.ActiveSpace = acPaperSpace
    ThisDrawing.ActiveLayout = ThisDrawing.ActiveLayout
   
    On Error Resume Next
    Set sset = ActiveDocument.SelectionSets.Add("Temp")
    If Err <> 0 Then
        Set sset = ActiveDocument.SelectionSets("Temp")
    End If
   
    On Error GoTo 0
    ReDim minPkt(0 To 2) As Double
    ReDim maxPkt(0 To 2) As Double
    minPkt = ThisDrawing.GetVariable("ExtMin")
    maxPkt = ThisDrawing.GetVariable("ExtMax")
   
    sset.Select acSelectionSetWindow, minPkt, maxPkt, BlockType, BlockData
   
    If sset.Count = 0 Then
        MsgBox "Kein Schriftfeld vorhanden", 64, "Hinweis"
        '--Ist der Papierbereich aktiv aber kein Schriftfeld vorhanden--!
        '--wird das Programm abgebrochen--------------------------------!
        Exit Sub
    Else
        For Each BlockEnt In sset
            Set BlockObj = BlockEnt
            If BlockObj.ObjectName = "AcDbBlockReference" Then
                If BlockObj.HasAttributes Then
                    AttWert = BlockObj.GetAttributes
                End If
            End If
        Next BlockEnt
       
        sset.Clear
        sset.Delete
    End If
StartMask.Show
End If
End Sub

---

------------------
Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP