Le portail francophone de la géomatique

Option Explicit
Dim MonPremierPoint
Dim MonSecondPoint
Dim MaLigne

Sub Init_Apa
        Set MaLigne = Nothing
        Set MonPremierPoint = Nothing
        Set MonSecondPoint = Nothing
end sub


Sub CutPolygon

    Dim MonBookMark
    MonBookMark = Application.Map.SelectionBookmark
    if MonBookMark = 0 then 
        msgbox "Selectionnez un polygone"
        exit sub
    end if

    Dim pSymbol
    Set pSymbol = Application.CreateAppObject("Symbol")
    pSymbol.MarkerStyle = 3 'cross
    pSymbol.MarkerSize = 10
    pSymbol.MarkerAngle = 0
    pSymbol.LineColor = 0 'black
    pSymbol.LineWidth = 2
    pSymbol.FillStyle = 0 'solid
    pSymbol.FillColor = 0 'Black
    Set MonSecondPoint = Application.CreateAppObject("Point")

    if MonPremierPoint Is Nothing then
        Map.Extent = Map.Extent
        Set MonPremierPoint = Application.CreateAppObject("Point")
        MonPremierPoint.x = Map.PointerX
        MonPremierPoint.y = Map.PointerY
        Call Map.DrawShape(MonPremierPoint, pSymbol)
    else
        Map.Extent = Map.Extent
        Dim pPoints,pSymbol2
        Set pSymbol2 = Application.CreateAppObject("Symbol")
        'Modify the symbol object for drawing the line
        pSymbol2.LineColor = 4210816      'brown
        pSymbol2.LineWidth = 2
        
        'Create a points collection and point object
        MonSecondPoint.x = Map.PointerX
        MonSecondPoint.y = Map.PointerY
        
        'Populate the points collection
        Set pPoints = Application.CreateAppObject("Points")
        pPoints.Add MonPremierPoint
        pPoints.Add MonSecondPoint
        
        'Create a line object and add the points collection to it
        Set MaLigne = Application.CreateAppObject("Line")
        Call MaLigne.Parts.Add(pPoints)
        
        'Draw the line with the updated symbology
        Call Map.DrawShape(MonSecondPoint, pSymbol)        
        Call Map.DrawShape(MaLigne, pSymbol2)

        Dim objSelLayer
        Set objSelLayer = Map.SelectionLayer
        Dim objRs',objRS2
        Set objRS = objSelLayer.Records
        'Set objRS2 = objSelLayer.Records

        objRS.Bookmark = MonBookMark
        Dim MonTableauPoly
        MonTableauPoly = objRS.Fields.Shape.Cut(MaLigne)
        if MonTableauPoly(0) Is Nothing Or MonTableauPoly(1) Is Nothing then 
            Set MaLigne = Nothing
            Set MonSecondPoint = Nothing
            Set MonPremierPoint = Nothing
            Set pSymbol = Nothing
            set objRS=nothing
            Set MaLigne = Nothing
            Set objSelLayer = Nothing
            Map.Extent = Map.Extent
            exit sub
        end if
        'set up sumbology for split feature
        Dim sym
        Set sym = Application.CreateAppObject("Symbol")
        sym.FillStyle = 0
        sym.LineWidth = 3
        sym.LineColor = sym.makecolor(0,0,255)         ' blue
        sym.FillColor = sym.makecolor(0,220,255)     ' cyan

        'Draw the polygons on the map
        call Map.DrawShape(MonTableauPoly(0), sym)
        call Map.DrawShape(MonTableauPoly(1), sym)
        call Map.Refresh

        If MsgBox("Etes vous sûr de vouloir couper ce polygone",vbYesNo,"QUIT?") = vbYes Then
            
            Dim MonNombreDeChamps
            MonNombreDeChamps = cint(objRS.Fields.count)
            Dim MonTableauValeur ()
            Redim MonTableauValeur (MonNombreDeChamps-3)
            Dim MonCompte    
            For MonCompte=0 to objRS.Fields.count-3
                MonTableauValeur(MonCompte) = objRS.Fields(MonCompte+2).Value 
            Next
            objRS.delete

            objRS.AddNew (MonTableauPoly(0))
            For MonCompte=0 to objRS.Fields.count-3
                 if objRS.Fields(MonCompte+2).name <> "Shape" then objRS.Fields(MonCompte+2).Value = MonTableauValeur(MonCompte)
            Next
            'Update the new record to save the changes
            objRS.Update

            objRS.AddNew (MonTableauPoly(1))
            For MonCompte=0 to objRS.Fields.count-3
                 if objRS.Fields(MonCompte+2).name <> "Shape" then objRS.Fields(MonCompte+2).Value = MonTableauValeur(MonCompte)
            Next
            'Update the new record to save the changes
            objRS.Update
        end if
        Set MaLigne = Nothing
        Set MonPremierPoint = Nothing
        Set MonSecondPoint = Nothing
        Set pSymbol = Nothing
        set objRS=nothing
        Set MaLigne = Nothing
        Set objSelLayer = Nothing
        Map.Extent = Map.Extent
    end if
end sub