Sub BMZ()
Dim UserName As String
UserName = ThisDrawing.GetVariable("LOGINNAME")
Dim objExcel As Variant
Dim blk As AcadBlockReference
Dim wrkb As Excel.Workbook
Dim wrks As Excel.Worksheet
Dim Array1 As Variant
Dim tag() As String
Dim newvarAttributes As Variant
If Dir(ThisDrawing.Path & "\Attributes.xls") <> "" Then
    On Error Resume Next
    'Check if Excel is open and if not open it.
    Set objExcel = GetObject(, "Excel.Application")
    If Err.Number > 0 Then
    Set objExcel = CreateObject("Excel.Application")
    End If
    objExcel.Visible = False
    
    Set wrkb = objExcel.Workbooks.Add
    Set wrks = objExcel.ActiveSheet
    Dim wbQuelle As Workbook
    Set wbQuelle = Workbooks.Open(ThisDrawing.Path & "\Attributes.xls")
    
    wbQuelle.Sheets(1).Cells.Copy Destination:=wrkb.Sheets(1).Cells
Else
    On Error Resume Next
    'Check if Excel is open and if not open it.
    Set objExcel = GetObject(, "Excel.Application")
    If Err.Number > 0 Then
    Set objExcel = CreateObject("Excel.Application")
    End If
    objExcel.Visible = False
    Set wrkb = objExcel.Workbooks.Add
    Set wrks = objExcel.ActiveSheet
    wrks.Rows(1).Font.Bold = True
    wrks.Rows(1).Font.ColorIndex = 5
    'Loop through modelspace
    wrks.Range("A" & 1) = "BLOCKNAME"
    wrks.Range("B" & 1) = "LAYERNAME"
    wrks.Range("C" & 1) = "EFFECTIVENAME"
    wrks.Range("D" & 1) = "XSCALE"
    wrks.Range("E" & 1) = "YSCALE"
    wrks.Range("F" & 1) = "ZSCALE"
End If

Dim rownr As Double
rownr = (Selection.CurrentRegion.Rows.Count) + 1
For Each blk In ThisDrawing.ModelSpace
    'wrks.Range("G1") = "NEW COLUMN NAME"
    'Fill the columns with block data from modelspace
    
    wrks.Range("A" & rownr) = blk.Name
    wrks.Range("B" & rownr) = blk.Layer
    wrks.Range("C" & rownr) = blk.EffectiveName
    wrks.Range("D" & rownr) = blk.XScaleFactor
    wrks.Range("E" & rownr) = blk.YScaleFactor
    wrks.Range("F" & rownr) = blk.ZScaleFactor
    newvarAttributes = blk.GetAttributes
    For i = LBound(newvarAttributes) To UBound(newvarAttributes)
        wrks.Range(Chr(i + 72 + i - 1) & rownr) = newvarAttributes(i).TagString
        wrks.Range(Chr(i + 72 + i) & rownr) = newvarAttributes(i).TextString
    Next i
    'wrks.Range("G" & rownr) = blk. .....Extend/change the column to any value you like
    rownr = rownr + 1
Next
ReDim tag(0 To UBound(newvarAttributes))
Dim cmax As Integer
wrks.Range("C1").Select
wrks.Columns.HorizontalAlignment = xlHAlignLeft
wrks.Columns.AutoFit
If Dir(ThisDrawing.Path & "\Attributes.xls") = "" Then
    wrks.SaveAs ThisDrawing.Path & "\Attributes.xls"
Else
    wbQuelle.Close
    Kill ThisDrawing.Path & "\Attributes.xls"
    wrks.SaveAs ThisDrawing.Path & "\Attributes.xls"
End If
cmax = Selection.CurrentRegion.Rows.Count
wrkb.Application.Quit
wrks.Application.Quit
wbQuelle.Close
'---------------------------------------------------------------------------------------------------------------
Dim obj As Object
Dim stockwerkmax As Double
Set obj = CreateObject("Excel.Application")
obj.Visible = False
obj.Workbooks.Open FileName:= _
ThisDrawing.Path & "\Attributes.xls"
Dim Stockwerk() As Integer
ReDim Stockwerk(0 To cmax)
Dim LoopNr() As Integer
ReDim LoopNr(0 To cmax)
Dim StringArray() As String
ReDim StringArray(0 To cmax)
Dim BmNr() As Integer
ReDim BmNr(0 To cmax)
Dim Bereich As Range
Set Bereich = Range("H:H")
Dim loopzaehler As Integer
Dim LoopVeryMax As Integer
Dim x As Integer
x = 0

For i = 0 To UBound(tag)
    tag(i) = obj.Range(Chr(i + 72 + i) & 2)
Next i
For i = 0 To cmax
    If ((obj.Range("C" & i + 1) Like "*Brand*") Or (obj.Range("C" & i + 1) Like "*melder*")) Then
            StringArray(i) = obj.Range("C" & i + 1)
            Stockwerk(i) = obj.Range("H" & i + 1)
            LoopNr(i) = obj.Range("j" & i + 1)
            BmNr(i) = obj.Range("l" & i + 1)
    End If
Next i
For i = 1 To cmax
    If (obj.Range("H" & i).Value > stockwerkmax) Then
        stockwerkmax = obj.Range("H" & i)
    End If
Next i
Dim LoopMax() As Integer
ReDim LoopMax(0 To stockwerkmax - 1)
For i = 0 To stockwerkmax - 1
    For b = 0 To cmax
        If obj.Range("h" & b) = i + 1 Then
            If obj.Range("j" & b) > LoopMax(i) Then
                LoopMax(i) = obj.Range("j" & b)
            End If
        End If
    Next b
Next i
For i = 0 To stockwerkmax - 1
    For b = 0 To UBound(StringArray)
        If Stockwerk(b) = i + 1 And LoopNr(b) > loopzaehler Then
            loopzaehler = loopzaehler + 1
            LoopVeryMax = LoopVeryMax + 1
        End If
    Next b
    loopzaehler = 0
Next i
loopzaehler = 0
Dim stockloop() As Integer
ReDim stockloop(0 To LoopVeryMax - 1, 0 To 1)
For i = 0 To stockwerkmax - 1
    For b = 0 To UBound(StringArray)
        If Stockwerk(b) = i + 1 And LoopNr(b) > loopzaehler Then
            stockloop(x, 0) = i + 1
            stockloop(x, 1) = LoopNr(b)
            loopzaehler = loopzaehler + 1
            x = x + 1
        End If
    Next b
    loopzaehler = 0
Next i
obj.Workbooks.Close
'----------------------------------------------------------------------------------------------------------

Dim pline As AcadLine
Dim spoints(0 To 2) As Double
Dim epoints(0 To 2) As Double
Dim z As Integer
Dim lengthbm As Double
Dim abstand As Double
Dim lengthbmz As Double
Dim liniehoehe As Double
Dim newlayer As AcadLayer
Dim BlockRef As AcadBlockReference
Dim insertionPnt(0 To 2) As Double
Dim xmax As Integer
Dim text As AcadText
Dim Angle
Dim abstandVonBmz As Double
Angle = 0
Dim insertionPointText(0 To 2) As Double
Dim insertionPointText2(0 To 2) As Double
Dim text1 As String

insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
'Prüfen ob Schema vorhanden ist ######################################################################
Dim dwgName As String
Dim NewDocument As AcadDocument
Dim AcadApp As AcadApplication
dwgName = "C:\Users\" & UserName & "\Documents\Schema.dwg"
If Dir(dwgName) <> "" Then
    Set AcadApp = GetObject(, "AutoCAD.Application")
    Set NewDocument = AcadApp.Documents.Open(dwgName)
Else
    Dim TemplateName As String
    TemplateName = "C:\Program Files\Autodesk\AutoCAD 2016\UserDataCache\de-de\Template\acad.dwt"  'Muss für jede AutocadVersion angepasst werden
    Set NewDocument = Documents.Add(TemplateName)
    NewDocument.SaveAs "Schema.dwg"
    Set BlockRef = NewDocument.ModelSpace.InsertBlock(insertionPnt, "\\pbs01\Projekte\Blockdateien\BrandmeldezentraleBlock.dwg", 1#, 1#, 1#, 0)
End If
'######################################################################################################
insertionPointText(0) = 0#: insertionPointText(1) = 0#: insertionPointText(2) = 0#
xmax = 0
z = 0
lengthbmz = 1171391
lengthbm = 173795
abstand = 326205
liniehoehe = 240484
abstandVonBmz = 1000000
NewDocument.Linetypes.Load "ACAD_ISO02W100", "acad.lin"
Set newlayer = NewDocument.Layers.Add("Trennlinie")
Set newlayer = NewDocument.Layers.Add("Grundlinie")
newlayer.color = acWhite
x = 0
For i = 0 To stockwerkmax - 1
    If i <> stockwerkmax - 1 Then
        x = x + LoopMax(i)
    End If
Next i
For i = stockwerkmax - 1 To stockwerkmax - 1                                    'i geht durch alle Stockwerke: St. 1, 2 ,3
    For d = 1 To LoopMax(i)                                      'd geht durch alle Loops: St.1: loop1, 2, 3
        insertionPnt(0) = abstandVonBmz + lengthbmz
        insertionPointText(0) = abstandVonBmz + lengthbmz + 204000
        insertionPnt(1) = x * 550000
        spoints(1) = x * 550000 + liniehoehe
        epoints(1) = spoints(1)
        spoints(0) = lengthbmz + abstandVonBmz
        epoints(0) = lengthbmz - abstand + abstandVonBmz
        For b = 1 To UBound(StringArray)                            'b geht einmal durch die gesamte Exceltabelle
            For c = 1 To UBound(StringArray)                        'c gleicht die Brandmeldernummern ab: St. 1 : loop 2: BmNummer 1
            If ((Stockwerk(c) = i + 1) And LoopNr(c) = d And BmNr(c) = b) Then
                    If insertionPnt(0) = abstandVonBmz + lengthbmz Then
                        'stockloop(x, 0) = i + 1
                        'stockloop(x, 1) = LoopNr(c)
                        insertionPointText2(0) = abstandVonBmz + lengthbmz - abstand
                        insertionPointText2(1) = x * 550000 + 25000 + liniehoehe
                        If LoopNr(c) = 1 Then
                            insertionPointText2(1) = insertionPointText2(1) + 50000
                        End If
                        text1 = "Stockwerk: " & i + 1 & " LoopNr: " & LoopNr(c)
                        Set text = NewDocument.ModelSpace.AddText(text1, insertionPointText2, 20000)
                        text.Alignment = acAlignmentFit
                        text.TextAlignmentPoint = insertionPointText2
                        text.Rotation = Angle
                    End If
                    If (StringArray(c) = "Druckknopfmelder") Then
                        insertionPnt(1) = x * 550000 + 160324
                    Else
                        insertionPnt(1) = x * 550000
                    End If
                    If LoopNr(c) = 1 Then
                        insertionPnt(1) = insertionPnt(1) + 50000
                    End If
                     If LoopNr(c) = 1 Then
                        spoints(1) = x * 550000 + liniehoehe + 50000
                        epoints(1) = spoints(1)
                    Else
                        spoints(1) = x * 550000 + liniehoehe
                        epoints(1) = spoints(1)
                    End If
                    Set BlockRef = NewDocument.ModelSpace.InsertBlock(insertionPnt, "\\pbs01\Projekte\Blockdateien\" & StringArray(c) & "Block.dwg", 1#, 1#, 1#, 0)
                    insertionPnt(0) = insertionPnt(0) + 500000
                    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
                    pline.Layer = "Trennlinie"
                    z = z + 1
                    spoints(0) = (lengthbmz) + ((z * lengthbm) + (z * abstand)) + abstandVonBmz - abstand
                    epoints(0) = (lengthbmz) + ((z * lengthbm) + ((z + 1) * abstand)) + abstandVonBmz - abstand
                    'Stockwerk und LoopNr und Brandmeldernummern zu Brandmeldern schreiben
                    '#####################################################################
                    insertionPointText(1) = x * 550000 + 320000
                    If LoopNr(c) = 1 Then
                        insertionPointText(1) = insertionPointText(1) + 50000
                    End If
                    text1 = Stockwerk(c)
                    Set text = NewDocument.ModelSpace.AddText(text1, insertionPointText, 60000)
                    text.Alignment = acAlignmentFit
                    text.color = acBlue
                    text.TextAlignmentPoint = insertionPointText
                    text.Rotation = Angle
                    insertionPointText(1) = insertionPointText(1) - 75000
                    text1 = LoopNr(c)
                    Set text = NewDocument.ModelSpace.AddText(text1, insertionPointText, 60000)
                    text.Alignment = acAlignmentFit
                    text.color = acCyan
                    text.TextAlignmentPoint = insertionPointText
                    text.Rotation = Angle
                    insertionPointText(1) = insertionPointText(1) - 75000
                    text1 = BmNr(c)
                    Set text = NewDocument.ModelSpace.AddText(text1, insertionPointText, 60000)
                    text.Alignment = acAlignmentFit
                    text.color = acGreen
                    text.TextAlignmentPoint = insertionPointText
                    text.Rotation = Angle
                    insertionPointText(0) = insertionPointText(0) + 500000
                    '#####################################################################
                    If z > xmax Then
                        xmax = z
                    End If
                
                End If
            Next c
        Next b
    'Loop zurückführen
    '##############################################
    epoints(0) = spoints(0) + 100000
    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
    spoints(0) = epoints(0)
    epoints(1) = epoints(1) + 150000
    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
    spoints(1) = epoints(1)
    epoints(0) = lengthbmz + abstandVonBmz - abstand
    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
    '##############################################
    z = 0
    x = x + 1
    Next d
Next i
Dim LayerObj As AcadEntity
For Each LayerObj In NewDocument.ModelSpace
    If LayerObj.Layer = "Grundlinie" Then
        LayerObj.Delete
    End If
Next LayerObj
'Stockwerkslinien und Stockwerksnummern einzeichnen
'###############################################################################
loopzaehler = 0
spoints(0) = lengthbmz + abstandVonBmz - abstand
epoints(0) = (lengthbmz) + ((xmax * lengthbm) + ((xmax + 1) * abstand)) + lengthbm + abstandVonBmz
spoints(1) = 0
epoints(1) = spoints(1)
Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
pline.Layer = "Grundlinie"
pline.Linetype = "ACAD_ISO02W100"
pline.LinetypeScale = 5000
For i = 0 To stockwerkmax - 1
    text1 = i + 1
    loopzaehler = loopzaehler + LoopMax(i)
    insertionPointText(0) = lengthbmz + 30000 + abstandVonBmz - abstand
    insertionPointText(1) = (loopzaehler) * 550000 - 30000
    Set text = NewDocument.ModelSpace.AddText(text1, insertionPointText, 100000)
    text.Alignment = acAlignmentTopLeft
    text.TextAlignmentPoint = insertionPointText
    text.Rotation = Angle
    text.Layer = "Grundlinie"
    spoints(1) = loopzaehler * 550000
    epoints(1) = spoints(1)
    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
    pline.Layer = "Grundlinie"
    pline.Linetype = "ACAD_ISO02W100"
    pline.LinetypeScale = 5000
Next i
'###############################################################################
spoints(0) = lengthbmz
epoints(0) = lengthbmz + 80000
insertionPointText(0) = epoints(0)
'Stockwers- und Loopnummern an die BMZ zeichnen #######################################
For i = 1 To LoopVeryMax
    spoints(1) = (1600000 / LoopVeryMax) * i
    epoints(1) = spoints(1)
    insertionPointText(1) = epoints(1) + 25000
    text1 = "Stockwerk: " & stockloop(i - 1, 0) & " LoopNr: " & stockloop(i - 1, 1)
    Set text = NewDocument.ModelSpace.AddText(text1, insertionPointText, 20000)
    text.Alignment = acAlignmentFit
    text.TextAlignmentPoint = insertionPointText
    text.Rotation = Angle
    text.Layer = "Grundlinie"
    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
    pline.Layer = "Grundlinie"
    spoints(1) = spoints(1) + 50000
    epoints(1) = spoints(1)
    Set pline = NewDocument.ModelSpace.AddLine(spoints, epoints)
    pline.Layer = "Grundlinie"
Next i
NewDocument.Save
NewDocument.Close
'#######################################################################################
'Kill ThisDrawing.Path & "\Attributes.xls"
'NewDocument.ActiveLinetype = NewDocument.Linetypes.Item("ByLayer")
End Sub