Public Sub CookieCutting()

Dim layCookie As rgLayer
Dim layoutNew As rgLayout
Dim mapTplt As rgMap
Dim sAreaName As String
Dim lActMapLeft As Long, lActMapTop As Long, lActMapWidth As Long, lActMapHeight As Long
Dim lNewMapIndex As Integer
Dim i As Long

' ... Überprüfen ob Landkarte aktiv

If ActiveMap Is Nothing Then

    MsgBox "Keine Karte Aktiv!"

    Exit Sub

End If

' ... Aktiver Layer muss Gebiets-, Flächen- oder Objektlayer sein

'     Hier: nicht Linienlayer oder nicht Punktelayer

If ActiveMap.WorkLayer.Layer.LayerType = ltLine Or ActiveMap.WorkLayer.Layer.LayerType = ltPoint Then

    MsgBox "Funktion für diesen Layer nicht möglich"

    Exit Sub

End If

Set layCookie = ActiveMap.WorkLayer.Layer

' ... Test ob alle Arbeitsblätter angelegt werden können

'     Als Name für Arbeitsblätter wird Kennungsspalte des Worklayers benutzt

For i = 0 To layCookie.ObjectCount - 1

    ' ... Kennung des Worklayer auslesen

    sAreaName = layCookie.GetValue(i, 0)

    ' ... Wenn ein Layout mit gleichem Namen vorhanden, dann Abbruch

    If Not Project.SearchLayoutByName(sAreaName) Is Nothing Then

        MsgBox "Layout mit Namen "  sAreaName " schon vorhanden!" ; vbCrLf & "Makro wird beendet"

        Exit Sub

    End If

Next i

' ... Alle Objekte auf Layer deselektieren

layCookie.SetObjectSelection -3, sfDeselect

' ... Verweis auf Vorlage

Set mapTplt = ActiveMap

' ... Ausdehnung der Landkarte merken

lActMapLeft = mapTplt.Left

lActMapTop = mapTplt.Top

lActMapWidth = mapTplt.Width

lActMapHeight = mapTplt.Height

' ... Alle Gebiete durchlaufen

For i = 0 To layCookie.ObjectCount - 1

   

    ' ... Region aus WorkLayer zum Übertragen markieren

    mapTplt.CopyRegion ActiveMap.WorkLayerIndex, i

   

    ' ... Neues Arbeitsblatt anlegen

    Set layoutNew = Project.NewLayout

    ' ... Name vergeben

    layoutNew.Name = layCookie.GetValue(i, 0)

    layoutNew.LoadLayout

    ' ... Landkartenbox auf Layout setzen

    lNewMapIndex = layoutNew.InsertMap(lActMapLeft, lActMapTop, lActMapWidth, lActMapHeight)

   

    ' ... Gebiet auf Karte einfügen

    layoutNew.maps.Item(lNewMapIndex).InsertRegion

   

    ' ... Landkarte einpassen

    layoutNew.maps.Item(lNewMapIndex).FitIn fitMap

    ' ... Neues Layout speichern und schliessen

    layoutNew.Save

    layoutNew.CloseLayout

   

Next i

MsgBox "CookieCutting beendet"

End Sub