Software Público Brasileiro

VERSION 5.00
Object = "{87AC6DA5-272D-40EB-B60A-F83246B1B8D7}#1.0#0"; "TeComDatabase.dll"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmVerificaConectividade 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Verificar Conectividade de Redes"
   ClientHeight    =   5385
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   5895
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5385
   ScaleWidth      =   5895
   StartUpPosition =   2  'CenterScreen
   Begin VB.CheckBox Check2 
      Caption         =   "Excluir Rede de Agua Nula"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   735
      TabIndex        =   9
      Top             =   3030
      Width           =   4800
   End
   Begin VB.CheckBox Check1 
      Caption         =   "Listar Rede de Agua Nula"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   255
      TabIndex        =   8
      Top             =   2715
      Width           =   5250
   End
   Begin VB.CheckBox chkDeletaCompOrfao 
      Caption         =   "Excluir Componente sem Rede de Agua"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   750
      TabIndex        =   7
      Top             =   2235
      Width           =   4860
   End
   Begin VB.CheckBox chkListaCompOrfao 
      Caption         =   "Listar Compomentes sem Rede de Agua"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   270
      TabIndex        =   6
      Top             =   1920
      Width           =   5400
   End
   Begin VB.CheckBox chkDistancia 
      Caption         =   "Listar e Corrigir distâncias"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   285
      TabIndex        =   5
      Top             =   1425
      Width           =   5175
   End
   Begin VB.Frame Frame2 
      Caption         =   "Selecione as ações"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3660
      Left            =   120
      TabIndex        =   10
      Top             =   1005
      Width           =   5655
   End
   Begin MSComctlLib.ProgressBar ProgBar1 
      Height          =   315
      Left            =   120
      TabIndex        =   4
      Top             =   4875
      Width           =   3000
      _ExtentX        =   5292
      _ExtentY        =   556
      _Version        =   393216
      BorderStyle     =   1
      Appearance      =   0
      Min             =   1e-4
      Scrolling       =   1
   End
   Begin VB.Frame Frame1 
      Caption         =   "Caminho do Relatório"
      Height          =   750
      Left            =   120
      TabIndex        =   2
      Top             =   150
      Width           =   5670
      Begin VB.TextBox Text1 
         Height          =   375
         Left            =   120
         TabIndex        =   3
         Top             =   255
         Width           =   5385
      End
   End
   Begin VB.CommandButton cmdCancelar 
      Caption         =   "Cancelar"
      Height          =   390
      Left            =   4560
      TabIndex        =   1
      Top             =   4830
      Width           =   1185
   End
   Begin VB.CommandButton cmdInciar 
      Caption         =   "Iniciar"
      Height          =   390
      Left            =   3285
      TabIndex        =   0
      Top             =   4830
      Width           =   1185
   End
   Begin TECOMDATABASELibCtl.TeDatabase TeDatabase1 
      Left            =   135
      OleObjectBlob   =   "frmVerificaConectividade.frx":0000
      Top             =   4830
   End
End
Attribute VB_Name = "frmVerificaConectividade"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Dim blnPontoCriado As Boolean
Dim ListComponents As String
Dim IdTabelaPoints As Integer
Dim IdTabelaLines As Integer

Private Sub cmdCancelar_Click()
   Unload Me
End Sub

Private Sub Form_Load()
    
   TeDatabase1.Provider = TpConexao 'usa a variável global para identificar o tipo de conexão
   TeDatabase1.Connection = Conn 'usa a variável global para identificar a conexão
   TeDatabase1.setCurrentLayer ("WATERLINES")
    
    Text1.Text = "C:\Arquivos de Programas\Geosan\Controles\DiagosticoRede" & Format(Now, "HHMM") & ".txt"
End Sub

Private Sub cmdInciar_Click()

On Error GoTo Trata_Erro
  



   Dim rsVBL As New ADODB.Recordset
   Dim rsVBP As New ADODB.Recordset
   Dim rsBusca As New ADODB.Recordset
   Dim rsLayer As New ADODB.Recordset
   Dim rsLinha As New ADODB.Recordset
   Dim VALID As Boolean
   Dim strsql As String

   Dim rsInitial As New ADODB.Recordset
   Dim rsInitial2 As New ADODB.Recordset
   Dim rsFinal As New ADODB.Recordset
   Dim rsFinal2 As New ADODB.Recordset
   Dim rsSemPoints As New ADODB.Recordset
   
   Dim rslinha1 As New ADODB.Recordset
   Dim rslinha2 As New ADODB.Recordset
   Dim QTDPT As Integer
   Dim retorno As Double
   Dim XL1 As Double, XL2 As Double, YL1 As Double, YL2 As Double
   
   Dim strXL1 As String, strXL2 As String, strYL1 As String, strYL2 As String
   
   Dim LINHA1 As String
   Dim LINHA2 As String
   Dim CONTALINHAS As Integer
   

   
   Me.MousePointer = vbHourglass
   
   'IDENTIFICA QUAL TABELA LINES O LAYER WATERLINES REGISTRA AS LOCALIZAÇÕES
   strsql = "SELECT LAYER_ID,NAME FROM TE_LAYER WHERE NAME = '" & "WATERLINES" & "'"
   Set rsLayer = Conn.execute(strsql)
   If rsLayer.EOF = True Then
      IdTabelaLines = rsLayer!layer_id
   Else
      MsgBox "Não localizada a tabela de geometrias 'LINES##' da tabela WATERLINES", vbExclamation, ""
      Exit Sub
   End If
   
   
   'IDENTIFICA QUAL TABELA POINTS O LAYER WATERCOMPONENTS REGISTRA AS LOCALIZAÇÕES
   strsql = "SELECT LAYER_ID,NAME FROM TE_LAYER WHERE NAME = '" & "WATERCOMPONENTS" & "'"
   Set rsLayer = Conn.execute(strsql)
   If rsLayer.EOF = True Then
      IdTabelaPoints = rsLayer!layer_id
   Else
      MsgBox "Não localizada a tabela de geometrias 'Points##' da tabela WATERCOMPONENTS", vbExclamation, ""
      Exit Sub
   End If
   
   
   Open Text1.Text For Output As #5 ' ABRE O ARQUIVO TEXTO PARA LOG
   
   
   If Me.chkDistancia.value = True Then
      corrigeDistancias 'inicializa o corretor de distancias
   End If
      
      
   'EXCLUI AS LINHAS QUE NÃO POSSUEM GEOMETRIA NA TABELA LINES1
   strsql = "SELECT OBJECT_ID_ FROM WATERLINES WHERE OBJECT_ID_ NOT IN (SELECT OBJECT_ID FROM LINES" & IdTabelaLines & ")"
   Set rsLinha = Conn.execute(strsql)
   If rsLinha.EOF = False Then
      Do While Not rsLinha.EOF
         'VERIFICADO QUE QUANDO A LINHA NÃO POSSUI GEOMETRIA, ELA NÃO APARECE NO MAPA
         'E POR ISSO O USUÁRIO NÃO PODE MANIPULA-LA
         Conn.execute ("DELETE FROM WATERLINES WHERE OBJECT_ID_ ='" & rsLinha!Object_id_ & "'")
         Print #5, "Linha " & rsLinha!Object_id_ & " SEM GEOMETRIA, EXCLUÍDA."
         rsLinha.MoveNext
      Loop
   End If
   
   
   'EXCLUI AS GEOMETRIAS DE LINHAS QUE NÃO TEM LINHAS NA TABELA WATERLINES
   strsql = "SELECT OBJECT_ID FROM LINES" & IdTabelaLines & " WHERE OBJECT_ID NOT IN (SELECT OBJECT_ID_ FROM WATERLINES)"
   Set rsLinha = Conn.execute(strsql)
   If rsLinha.EOF = False Then
      Do While Not rsLinha.EOF
         Conn.execute ("DELETE FROM LINES1 WHERE OBJECT_ID ='" & IdTabelaLines & "'")
         Print #5, "DESENHO DE Linha COD " & rsLinha!object_id & " SEM INFORMAÇÃO DE CADASTRO, EXCLUÍDA."
         rsLinha.MoveNext
      Loop
   End If
   
   
   
   
   'COM O SELECT ABAIXO OBTEM-SE UMA LISTA DOS COMPONENTES DE REDE QUE EXISTEM NA TABELA WATERCOMPONENTES MAS NÃO TEM INFORMAÇÃO GEOGRAFICA
   
   If TpConexao = 1 Then 'CASO SQL SERVER, CARREGA O RECORDSET DIRETO POR UM COMANDO
   
      strsql = "SELECT OBJECT_ID_ FROM WATERCOMPONENTS WHERE OBJECT_ID_ NOT IN (SELECT OBJECT_ID FROM POINTS" & IdTabelaPoints & ")"
      Set rsSemPoints = Conn.execute(strsql)
   
   Else 'CASO ORACLE, FAZ UM LOOP BUSCANDO OS PONTOS NÃO ENCONTRADOS E PASSA A LISTA PARA O COMANDO DO RECORDSET
      
      LISTA_COMPONENTE_SEM_GEOMETRIA 'CARREGA UM ARRAY QUE SERÁ USADO NO LUGAR DO RECORDSET
   
      strsql = "SELECT OBJECT_ID_ FROM WATERCOMPONENTS WHERE OBJECT_ID_ IN (" & ListComponents & ")"

   End If
   Set rsSemPoints = Conn.execute(strsql)
   
   
   
   If rsSemPoints.EOF = False Then
      Do While Not rsSemPoints.EOF = True
         id_componente = rsSemPoints!Object_id_
         
         'VERIFICANDO A QUAL LINHA ESTE COMPONENTE É COMPONENTE INICIAL
         Set rsInitial = Conn.execute("SELECT LINE_ID,OBJECT_ID_,INITIALCOMPONENT FROM WATERLINES WHERE INITIALCOMPONENT ='" & id_componente & "'")
         
         If rsInitial.EOF = False Then
            'chegando a este ponto significa que o componente é inicial de 1 ou mais linhas
            LINHA1 = rsInitial!Object_id_ 'carrega em LINHA1 o id da linha que o componente é inicial
            
            retorno = TeDatabase1.getPointOfLine(0, LINHA1, 0, XL1, YL1) 'retorna em XL1 e YL1 as coordenadas iniciais da linha

            'VERIFICANDO SE O COMPONENTE É TAMBEM FINAL DE ALGUMA OUTRA LINHA
            Set rsFinal = Conn.execute("SELECT LINE_ID,OBJECT_ID_,FINALCOMPONENT FROM WATERLINES WHERE FINALCOMPONENT ='" & id_componente & "'AND OBJECT_ID_ <> '" & LINHA1 & "'")
            If rsFinal.EOF = False Then
               LINHA2 = rsFinal!Object_id_
               'chegando a este ponto significa que o componente é inicial e final de duas OU mais linhas
               'ANALISAR AS 2 LINHAS
               
               'FAZER A PESQUISA PARA SABER O X,Y DAS LINHAS
               
               QTDPT = TeDatabase1.getQuantityPointsLine(0, LINHA2) 'retorna número de pontos que compõem a linhA para pegar as coordenadas do ultimo ponto
               If QTDPT >= 2 Then
                  retorno = TeDatabase1.getPointOfLine(0, LINHA2, QTDPT - 1, XL2, YL2) 'retorna em XL2 e YL2 as coordenadas finais da linha
               End If
              

               If XL1 = XL2 And YL1 = YL2 Then
                  strsql = "insert into points2 (object_id,x,y) values ('" & id_componente & "'," & XL1 & "," & YL1 & "')"
                  Conn.execute (strsql)
                  Print #5, "Componente " & id_componente & " localizado com sucesso!"
                  
               Else
                  'MsgBox "Valor inconsistente para o componente de rede nº " & id_componente & " contido nas linhas " & LINHA1 & " e " & LINHA2 & "." & Chr(13) & Chr(13) & "Não foi possivel corrigir automaticamente.", vbExclamation, ""
                  Print #5, "Valor inconsistente para o componente de rede nº " & id_componente & " contido nas linhas " & LINHA1 & " e " & LINHA2 & ". Não foi possivel corrigir automaticamente."
               End If
            
            Else
               'chegando a este ponto significa que o componente é somente inicial de duas ou mais linhas
               'ANALIZAR A LINHA QUE ELE É INICIAL

               CONTALINHAS = 1
               rsInitial.MoveNext
               Do While Not rsInitial.EOF = True
                  CONTALINHAS = CONTALINHAS + 1
               Loop
               If CONTALINHAS = 1 Then 'O PONTO ESTÁ CONECTADO A SOMENTE 1 LINHA
               
                  'retorno = TeDatabase1.getPointOfLine(0, rsInitial!Object_id_, 0, XL1, YL1)
                  
                  strXL1 = Replace(XL1, ",", ".") 'converte o valor double do XL1
                  strYL1 = Replace(YL1, ",", ".") 'converte o valor double do YL1
                  
                  strsql = "insert into points2 (object_id,x,y) values ('" & id_componente & "'," & strXL1 & "," & strYL1 & ")"
                  
                  Conn.execute (strsql)
                  Print #5, "Componente " & id_componente & " localizado com sucesso!"
                  
               
               Else 'O PONTO ESTÁ CONECTADO A MAIS DE 1 LINHA
                  Set rsInitial2 = Conn.execute("SELECT LINE_ID,OBJECT_ID_,INITIALCOMPONENT FROM WATERLINES WHERE INITIALCOMPONENT ='" & id_componente & "' AND OBJECT_ID_ <> '" & LINHA1 & "'")
                  If rsInitial2.EOF = False Then
                     LINHA2 = rsInitial2!Object_id_
                     retorno = TeDatabase1.getPointOfLine(0, rsInitial2!Object_id_, 0, XL2, YL2)
                     
                     If XL1 = XL2 And YL1 = YL2 Then
                        strXL1 = Replace(XL1, ",", ".") 'converte o valor double do XL1
                        strYL1 = Replace(YL1, ",", ".") 'converte o valor double do YL1
                        strsql = "insert into points2 (object_id,x,y) values ('" & id_componente & "'," & XL1 & "," & YL1 & "')"
                        Conn.execute (strsql)
                        Print #5, "Componente " & id_componente & " localizado com sucesso!"
                     Else
                        
                        'MsgBox "Valores inconsistentes para a linha " & LINHA1 & " e linha " & LINHA2 & "." & Chr(13) & Chr(13) & "Não foi possivel corrigir automaticamente.", vbExclamation, ""
                        Print #5, "Valores inconsistentes para a linha " & LINHA1 & " e linha " & LINHA2 & ". Não foi possivel corrigir automaticamente."
                     End If
                  Else
                  
                     'MsgBox "Valores inconsistentes para a linha " & LINHA1 & "." & Chr(13) & Chr(13) & "Não foi possivel corrigir automaticamente.", vbExclamation, ""
                     Print #5, "Valores inconsistentes para a linha " & LINHA1 & ". Não foi possivel corrigir automaticamente."
                  End If
                  
               End If
               
            End If
            
         Else
            'chegando a este ponto significa que o componente não é inicial de nenhuma linha
            'verificando se ele é final de alguma linha
            Set rsFinal = Conn.execute("SELECT LINE_ID,OBJECT_ID_,FINALCOMPONENT FROM WATERLINES WHERE FINALCOMPONENT ='" & id_componente & "'")
            If rsFinal.EOF = False Then
               'chegando a este ponto significa que o componente é somente final de duas ou mais linhas
            
               LINHA1 = rsFinal!Object_id_
               retorno = TeDatabase1.getPointOfLine(0, LINHA1, 0, XL1, YL1)
            
               CONTALINHAS = 1
               rsFinal.MoveNext
               Do While Not rsFinal.EOF = True
                  CONTALINHAS = CONTALINHAS + 1
               Loop
               
               If CONTALINHAS = 1 Then 'O PONTO ESTÁ CONECTADO A SOMENTE 1 LINHA
               
                  
                  strXL1 = Replace(XL1, ",", ".") 'converte o valor double do XL1
                  strYL1 = Replace(YL1, ",", ".") 'converte o valor double do YL1
                  
                  strsql = "insert into points" & IdTabelaPoints & " (object_id,x,y) values ('" & id_componente & "'," & strXL1 & "," & strYL1 & ")"
                  
                  Conn.execute (strsql)
                  Print #5, "Componente " & id_componente & " localizado com sucesso!"
               
               Else 'O PONTO ESTÁ CONECTADO A MAIS DE 1 LINHA
                  Set rsFinal2 = Conn.execute("SELECT LINE_ID,OBJECT_ID_,INITIALCOMPONENT FROM WATERLINES WHERE INITIALCOMPONENT ='" & id_componente & "' AND OBJECT_ID_ <> '" & LINHA1 & "'")
                  If rsFinal2.EOF = False Then
                     
                     LINHA2 = rsFinal2!Object_id_
                     retorno = TeDatabase1.getPointOfLine(0, rsFinal2!Object_id_, 0, XL2, YL2)
                     
                     If XL1 = XL2 And YL1 = YL2 Then
                        strsql = "insert into points2 (object_id,x,y) values ('" & id_componente & "'," & XL1 & "," & YL1 & "')"
                        Conn.execute (strsql)
                        Print #5, "Componente " & id_componente & " localizado com sucesso!"
                     Else
                        
                        Print #5, "Valores inconsistentes para a linha " & LINHA1 & " e linha " & LINHA2 & "." & Chr(13) & Chr(13) & "Não foi possivel corrigir automaticamente."
                     End If
                  Else
                  
                     Print #5, "Valores inconsistentes para a linha " & LINHA1 & "." & Chr(13) & Chr(13) & "Não foi possivel corrigir automaticamente."
                     
                  End If
                  
               End If
            
            
            Else
               'chegando a este ponto significa que o componente não é inicial nem final de linhas
               
               If chkDeletaCompOrfao.value = True Then
                  
                  strCMD = "DELETE FROM WATERCOMPONENTS WHERE OBJECT_ID_ ='" & id_componente & "'"
                  Conn.execute (strCMD)
                  Print #5, "Componente de rede " & id_componente & " sem conexões. >> Excluído."
               
               Else
                  Print #5, "Componente de rede " & id_componente & " sem conexões. >> Não Excluído."
               
               End If

            
            End If
               
         End If
         rsSemPoints.MoveNext
      Loop
   End If
   
   Print #5, ""
   Print #5, " * * * * FIM DE VERIFICAÇÃO DE GEOMETRIAS * * * *"
   Print #5, ""
   
   Set rsVBL = Conn.execute("SELECT OBJECT_ID_ AS COD,INITIALCOMPONENT AS INI FROM WATERLINES ORDER BY INITIALCOMPONENT")
   If rsVBL.EOF = False Then
       Set rsVBP = Conn.execute("SELECT COMPONENT_ID AS COMPONENTE FROM WATERCOMPONENTS ORDER BY COMPONENT_ID")
       'VALIDANDO TODOS OS COMPONENTES INITIAL DA WATERLINES
       If rsVBP.EOF = False Then
           Do While Not rsVBP.EOF = True And Not rsVBL.EOF = True
               If rsVBP!COMPONENTE = rsVBL!ini Then 'validado
                   rsVBL.MoveNext
                   VALID = True
               ElseIf rsVBP!COMPONENTE < rsVBL!ini Then
                   rsVBP.MoveNext
                   VALID = False
               Else
                   Print #5, "Componente Inicial:"; Tab(21); rsVBL!ini; Tab(31); "da linha"; Tab(40); rsVBL!COD; Tab(50); "NÃO ENCONTRADO."
                   
                   'CriaComponenteDefault (rsVBL!ini)
                   If blnPontoCriado = True Then
                       Print #5, "Componente " & rsVBL!ini & " POSSUI GEOMETRIA E FOI CRIADO AUTOMATICAMENTE."
                   Else
                       Print #5, "Componente " & rsVBL!ini & " NÃO PODE SER CRIADO AUTOMATICAMENTE."
                   End If
                   
                   rsVBL.MoveNext
               End If
               If rsVBP.EOF = True Then
                   If VALID = False Then
                       Do While Not rsVBL.EOF = True
                           Print #5, "Componente Inicial:"; Tab(21); rsVBL!ini; Tab(31); "da linha"; Tab(40); rsVBL!COD; Tab(50); "não encontrado!"
                           
                           CriaComponenteDefault (rsVBL!ini)
                           If blnPontoCriado = True Then
                               Print #5, "Componente " & rsVBL!ini & " POSSUI GEOMETRIA E FOI CRIADO AUTOMATICAMENTE."
                           Else
                               Print #5, "Componente " & rsVBL!ini & " NÃO PODE SER CRIADO AUTOMATICAMENTE."
                           End If
                           rsVBL.MoveNext
                       Loop
                   End If
                   Exit Do
               End If
           Loop
       End If
   End If
   Print #5, ""
   Print #5, " * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
   Print #5, ""
   Set rsVBL = Conn.execute("SELECT OBJECT_ID_ AS COD,FINALCOMPONENT AS FIM FROM WATERLINES ORDER BY FINALCOMPONENT")
   If rsVBL.EOF = False Then
       Set rsVBP = Conn.execute("SELECT COMPONENT_ID AS COMPONENTE FROM WATERCOMPONENTS ORDER BY COMPONENT_ID")
       'VALIDANDO TODOS OS COMPONENTES FINAL DA WATERLINES
       If rsVBP.EOF = False Then
           Do While Not rsVBP.EOF = True And Not rsVBL.EOF = True
               If rsVBP!COMPONENTE = rsVBL!fim Then 'validado
                   rsVBL.MoveNext
                   VALID = True
               ElseIf rsVBP!COMPONENTE < rsVBL!fim Then
                   rsVBP.MoveNext
                   VALID = False
               Else
                   Print #5, "Componente Final:"; Tab(21); rsVBL!fim; Tab(31); "da linha"; Tab(40); rsVBL!COD; Tab(50); "NÃO ENCONTRADO."
                   
                   CriaComponenteDefault (rsVBL!fim)
                   If blnPontoCriado = True Then
                       Print #5, "Componente " & rsVBL!fim & " POSSUI GEOMETRIA E FOI CRIADO AUTOMATICAMENTE."
                   Else
                       Print #5, "Componente " & rsVBL!fim & " NÃO PODE SER CRIADO AUTOMATICAMENTE."
                   End If
   
                   rsVBL.MoveNext
               End If
               If rsVBP.EOF = True Then
                   If VALID = False Then
                       Do While Not rsVBL.EOF = True
                           Print #5, "Componente Final:"; Tab(21); rsVBL!fim; Tab(31); "da linha"; Tab(40); rsVBL!COD; Tab(50); "não encontrado!"
                           
                           CriaComponenteDefault (rsVBL!fim)
                           If blnPontoCriado = True Then
                              Print #5, "Componente " & rsVBL!fim & " POSSUI GEOMETRIA E FOI CRIADO AUTOMATICAMENTE."
                           Else
                              Print #5, "Componente " & rsVBL!fim & " NÃO PODE SER CRIADO AUTOMATICAMENTE."
                           End If
                           
                           rsVBL.MoveNext
                       Loop
                   End If
                   Exit Do
               End If
           Loop
       End If
   End If
   
   Close #5 'FECHA O ARQUIVO TEXTO PARA LOG
   
   rsVBL.Close
   rsVBP.Close
   Me.MousePointer = vbDefault
   MsgBox "foi gerado em " & Text1.Text & " um relatório contendo o diagnóstico de rede.", vbInformation, ""
   Unload Me
   

Trata_Erro:

If Err.Number = 0 Or Err.Number = 20 Then
    Resume Next
Else
   'Resume
   Me.MousePointer = vbDefault
   Open App.path & "\Controles\GeoSanLog.txt" For Append As #1
   Print #1, Now & " " & strUser & " " & Versao_Geo & " - frmVerificaConectividade - cmdInciar_Click - " & Err.Number & " - " & Err.Description
   Close #1
   MsgBox "Um posssível erro foi identificado:" & Chr(13) & Chr(13) & Err.Description & Chr(13) & Chr(13) & "Foi gerado na pasta do aplicativo o arquivo GeoSanLog.txt com informações desta ocorrência.", vbInformation

End If

End Sub
Private Function CriaComponenteDefault(ident As Long) As Boolean

On Error GoTo Trata_Erro
   
   Dim rsBusca As New ADODB.Recordset
   Dim rsLayer As New ADODB.Recordset
   Dim strsql As String

   Set rsBusca = Conn.execute("SELECT * FROM POINTS" & IdTabelaPoints & " WHERE OBJECT_ID = '" & ident & "'")
   If rsBusca.EOF = False Then 'A GEOMETRIA DO PONTO EXISTE
         
      Set rsBusca = Conn.execute("SELECT * FROM WATERCOMPONENTS WHERE OBJECT_ID_ = '" & ident & "'")
      If rsBusca.EOF = True Then
         Dim strCMD As String
         strCMD = "SET IDENTITY_INSERT WATERCOMPONENTS ON;"
         strCMD = strCMD & "INSERT INTO WATERCOMPONENTS (COMPONENT_ID,OBJECT_ID_,SECTOR) VALUES (" & ident & "," & ident & ",999);"
         strCMD = strCMD & "SET IDENTITY_INSERT WATERCOMPONENTS OFF"
         'MsgBox strCMD
         Conn.execute (strCMD) 'insere o ponto na watercomponents
         blnPontoCriado = True
      Else ' O PONTO JA FOI CRIADO NO PROCESSO ANTERIOR
         blnPontoCriado = True
      End If
         
   Else 'A GEOMETRIA DO PONTO NÃO EXISTE
      blnPontoCriado = False
   End If


Trata_Erro:

If Err.Number = 0 Or Err.Number = 20 Then
    Resume Next
Else
   blnPontoCriado = False
   Exit Function
End If


End Function

Private Function LISTA_COMPONENTE_SEM_GEOMETRIA() 'carrega em ListComponents os componentes não encontrados na tabela points
   
   'FUNÇÃO PARA VERIFICAR SE OS OBJECT_ID NA TABELA POINTS POSSUEM UM OBJECT_ID_ NA WATERCOMPONENTS
   'CRIA UMA LISTA DE ID's DE WATERCOMPONENTS QUE NÃO FORAM ENCONTRADOS
   Dim rsWTC As New ADODB.Recordset
   Dim rsPOINT As New ADODB.Recordset
   
   Set rsWTC = Conn.execute("SELECT OBJECT_ID_ AS ID_COMP, LENGTH(OBJECT_ID_) AS TAM FROM WATERCOMPONENTS ORDER BY TAM, OBJECT_ID_")
   
   'SELECT OBJECT_ID_, LENGTH(OBJECT_ID_) AS TAM from WATERCOMPONENTS ORDER BY TAM, OBJECT_ID_
   
   If rsWTC.EOF = False Then
       Set rsPOINT = Conn.execute("SELECT OBJECT_ID AS ID_POINT, LENGTH(OBJECT_ID) AS TAM FROM POINTS" & IdTabelaPoints & " ORDER BY TAM, OBJECT_ID")
       
       Open Text1.Text For Append As #4
       'COMPARANDO OS ID's
       
       If rsPOINT.EOF = False Then
           Do While Not rsPOINT.EOF = True And Not rsWTC.EOF = True
               If CDbl(rsPOINT!ID_POINT) = CDbl(rsWTC!id_comp) Then 'validado
                   rsWTC.MoveNext
                   VALID = True
               ElseIf CDbl(rsPOINT!ID_POINT) < CDbl(rsWTC!id_comp) Then
                   rsPOINT.MoveNext
                   VALID = False
               Else
                   If ListComponents = "" Then
                        ListComponents = rsWTC!id_comp
                   Else
                        ListComponents = ListComponents & "," & rsWTC!id_comp
                   End If
                   rsWTC.MoveNext
               End If
               If rsVBP.EOF = True Then
                  If VALID = False Then
                     Do While Not rsWTC.EOF = True
                        
                        If ListComponents = "" Then
                           ListComponents = rsWTC!id_comp
                        Else
                           ListComponents = ListComponents & "," & rsWTC!id_comp
                        End If

                        rsWTC.MoveNext
                     Loop
                     End If
                  Exit Do
               End If
           Loop
       End If
   End If

Close #4

End Function

Private Function corrigeDistancias()
On Error GoTo Trata_Erro

   Dim rs As New ADODB.Recordset
   Dim rsWaterlines As New ADODB.Recordset
   Dim qtdPtosLinha As Integer
   Dim retorno As Long
   Dim dblDistancia As Double
   Dim x_1 As Double
   Dim y_1 As Double
   Dim x_2 As Double
   Dim y_2 As Double
   Dim i As Integer
   Dim strDistancia As String
   Dim strLinha As String
   Dim contacorrigidos As Long
   
   contacorrigidos = 0

   strsql = "SELECT LEN(OBJECT_ID_) AS TAM, OBJECT_ID_, LENGTHCALCULATED FROM WATERLINES ORDER BY TAM, OBJECT_ID_"
   Set rsWaterlines = Conn.execute(strsql)
   
   rsWaterlines.MoveFirst 'processo para definir valores para a barra de progresso
   retorno = 0
   Do While Not rsWaterlines.EOF
      retorno = retorno + 1
      rsWaterlines.MoveNext
   Loop
   ProgBar1.Max = retorno
   ProgBar1.value = 1
   
   Me.MousePointer = vbHourglass
   
   Open Text1.Text For Append As #4
   Print #4, "RECALCULANDO DISTANCIAS >> INICIO >>"
   rsWaterlines.MoveFirst
   Do While Not rsWaterlines.EOF
      DoEvents
      strLinha = rsWaterlines!Object_id_
      dblDistancia = 0
      
      qtdPtosLinha = TeDatabase1.getQuantityPointsLine(0, strLinha) 'retorna número de pontos que compõem a linha. se maior que 2 significa que tem vertices
      
      If qtdPtosLinha > 2 Then 'existem vértices na linha
               
         retorno = TeDatabase1.getPointOfLine(0, strLinha, 0, x_1, y_1) 'retorna em x_1 e Y_1 as coordenadas do inicio da linha
         
         For i = 1 To qtdPtosLinha - 1
            
            retorno = TeDatabase1.getPointOfLine(0, strLinha, i, x_2, y_2) 'retorna em x_2 e Y_2 as coordenadas do proximo ponto
            
            dblDistancia = dblDistancia + DistanceBetween(x_1, y_1, x_2, y_2) 'carrega em distancia a soma
            
            x_1 = x_2
            y_1 = y_2
            
         Next
      
      ElseIf qtdPtosLinha = 2 Then
         
         retorno = TeDatabase1.getPointOfLine(0, strLinha, 0, x_1, y_1) 'retorna em x_1 e Y_1 as coordenadas do inicio da linha
         retorno = TeDatabase1.getPointOfLine(0, strLinha, 1, x_2, y_2) 'retorna em x_2 e Y_2 as coordenadas do fim da linha
         
         dblDistancia = DistanceBetween(x_1, y_1, x_2, y_2) 'carrega em distancia a soma
         
      End If
      
      dblDistancia = Round(dblDistancia, 2)
      
      If rsWaterlines!LENGTHCALCULATED <> dblDistancia Then
         
         strDistancia = Replace(dblDistancia, ",", ".")
         
         Conn.execute "UPDATE WATERLINES SET LENGTHCALCULATED=" & strDistancia & " WHERE OBJECT_ID_=" & strLinha
         
         'SELECT ORDER BY DESC PARA PEGAR A ULTIMA LINHA DO GRUPO DE 3
         Set rs = Conn.execute("SELECT GEOM_ID,OBJECT_ID,TEXT_VALUE FROM TEXTS1 WHERE OBJECT_ID = " & strLinha & " ORDER BY GEOM_ID DESC")
         rs.Close
         rs.Open "SELECT GEOM_ID,OBJECT_ID,TEXT_VALUE FROM TEXTS1 WHERE OBJECT_ID = " & strLinha & " ORDER BY GEOM_ID DESC", Conn, adOpenKeyset, adLockOptimistic
         If rs.EOF = False Then
            rs!TEXT_VALUE = dblDistancia
            rs.Update
         End If
         rs.Close
         
         Print #4, "Linha"; Tab(11); strLinha; Tab(21); "RECALCULADO DE"; Tab(38); rsWaterlines!LENGTHCALCULATED; Tab(50); "PARA"; Tab(55); dblDistancia
         contacorrigidos = contacorrigidos + 1
      End If
      
      If ProgBar1.Max > ProgBar1.value Then ProgBar1.value = ProgBar1.value + 1 Else ProgBar1.value = 1
      
      rsWaterlines.MoveNext
      
   Loop
   Me.MousePointer = Default
   Print #4, ""
   Print #4, "RECALCULADAS " & contacorrigidos & " DE UM TOTAL DE " & ProgBar1.Max & " LINHAS."
   Print #4, "RECALCULANDO DISTANCIAS >> FIM >>"
   Close #4

Trata_Erro:

If Err.Number = 0 Or Err.Number = 20 Then
    Resume Next
ElseIf Err.Number = 55 Then
   Close #4
   Resume
Else
   
   MsgBox Err.Number & " " & Err.Description
   Me.MousePointer = vbDefault
   Open App.path & "\Controles\GeoSanLog.txt" For Append As #1
   Print #1, Now & " " & strUser & " " & Versao_Geo & " - Private Function corrigeDistancias() - " & Err.Number & " - " & Err.Description
   Close #1
   MsgBox "Um posssível erro foi identificado:" & Chr(13) & Chr(13) & Err.Description & Chr(13) & Chr(13) & "Foi gerado na pasta do aplicativo o arquivo GeoSanLog.txt com informações desta ocorrência.", vbInformation

End If
End Function

Private Function DistanceBetween(ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double) As Double
  ' Calculate the distance between two points, given their X/Y coordinates.
  
  ' The short version...
  DistanceBetween = Sqr((Abs(X2 - X1) ^ 2) + (Abs(Y2 - Y1) ^ 2))
  
End Function