Uporabne rutine

Povezave do otokov

• Verzija: 1.0
• Datum: 1.6.2011
• Avtor: Aleš Trtnik

Ta rutina najde v poligonski plasti vse povezave do otokov. Najdene povezave zapiše v drugo plast.

Sub PovezaveDoOtokov
  Dim I, J, K As Long, L, L1 As TLayer, PA, PB As TPointArray, Check, Check1 As Boolean
  L = [Poligonska plast]  //Vhodni podatki
  L1 = [Linijska plast]   //Izhodni podatki (Vsebina se izbriše)
  L1.DeleteAllData (True)
  L1.BeginMultipleUpdate
  For I = 0 To L.AllRecords.Count - 1
    HintNum2 ("A", I, L.AllRecords.Count)
    PB = L.AllRecords.Items (I).PointArray
    PB.DeletePoint (0)
    PB.Sort
    Check = False
    For J = 0 To PB.Count - 2
      If (PB.Y(J) = PB.Y(J+1)) And (PB.X(J) = PB.X(J+1)) Then
        Check = True
        Break
      EndIf
    Next
    If Check Then
      For J = PB.Count - 2 To 0 Step - 1
        If Not ((PB.Y(J) = PB.Y(J+1)) And (PB.X(J) = PB.X(J+1))) Then
          PB.DeletePoint (J+1)
          If J = 0 Then PB.DeletePoint (0) EndIf
        EndIf
      Next
      PA = L.AllRecords.Items (I).PointArray
      For J = 0 To PA.Count - 3
        If (PB.Find (pa.Y(J), pa.X(J)) >= 0) And
           (PB.Find (pa.Y(J+1), pa.X(J+1)) >= 0) Then
          HintNum4 ("B", I, L.AllRecords.Count, J, PB.Count)
          For K = J + 2 To PA.Count - 1
            If (pa.Y(J) = pa.Y(K)) And (pa.X(J) = pa.X(K)) Then
              Check1 = ((pa.Y(J+1) = pa.Y(K-1)) And (pa.X(J+1) = pa.X(K-1)))
              If Not Check1 And (K < PA.Count - 1)Then
                Check1 = ((pa.Y(J+1) = pa.Y(K+1)) And (pa.X(J+1) = pa.X(K+1)))
              EndIf
              If Check1 Then
                L1.EditRecord.Append
                L1.EditRecord.SetPolyline
                L1.EditRecord.AddPoint (pa.Y(J), pa.X(J))
                L1.EditRecord.AddPoint (pa.Y(J+1), pa.X(J+1))
                L1.EditRecord.AutoCentroid
                L1.EditRecord.Update
                Check = True
              EndIf
            EndIf
          Next
        EndIf
      Next
      Destroy (PA)
    EndIf
  Next
  Destroy (PB)
  L1.EndMultipleUpdate
  L1.Optimize
EndSub