Sub FichXExplorerHTA(DR As String) 'temp as string 'Dim Fs As Object 'Dim RstDeparts As Recordset Dim repTx, Fichier, vLat, vLong, vX, vY, Symbole As String 'Dim Vnum1 As Double Dim i, j, k, N As Integer Dim Couleur As Long Dim Trait As Integer Dim Aerien As Boolean Dim RetourDirFich As Boolean Dim departHta() As String Dim Parametres() As String Dim segmentHta() As String Dim strSql As String Dim strCoord As String Dim point() As String Dim ia() As String Dim poste() As String Dim coordonnees() As String 'ThisWorkbook.Worksheets("Principal").Range("EnCours").Select Application.DisplayAlerts = True Worksheets("Principal").Range("Operation") = "Génération des fichiers HTA, Postes et IA pour PhotoExploreur" Application.DisplayAlerts = False Debug.Print "Génération des tracés HTA pour PhotoExplorer" On Error Resume Next MkDir RepResultat & "PhotoExploreur" MkDir RepResultat & "PhotoExploreur\HTA" MkDir RepResultat & "PhotoExploreur\HTA_Aerien" MkDir RepResultat & "PhotoExploreur\IA-Postes" On Error GoTo 0 repTx = RepResultat & "PhotoExploreur\" ' ouvre la connexion ADODB ConnectBdd "" ReDim Parametres(1) Parametres(1) = DR strSql = RqSelect("Requete_Liste_departsHTA", Parametres()) 'Debug.Print strSql departHta() = rqResultat(strSql) If ValidTraitement = False Then GoTo err If departHta(1, 1) = "False" Then Else Fichier = " Reseau HTA.txt" RetourDirFich = DirFich(Fichier, repTx & "HTA\") If RetourDirFich = True Then Kill (repTx & "HTA\" & Fichier) Open repTx & "HTA\" & Fichier For Append Shared As #5 Fichier = " Postes et IA.txt" RetourDirFich = DirFich(Fichier, repTx & "IA-Postes\") If RetourDirFich = True Then Kill (repTx & "IA-Postes\" & Fichier) Open repTx & "IA-Postes\" & Fichier For Append Shared As #7 ' boucle sur l'ensemble de la liste des départs For i = 1 To UBound(departHta, 1) 'If i > 10 Then Exit For If posteSource = "" Then GoTo suite If LCase(posteSource) <> "complet" And posteSource <> departHta(i, 1) Then GoTo suite Application.DisplayAlerts = True Worksheets("Principal").Range("B2").Select Worksheets("Principal").Range("EnCours") = departHta(i, 2) & " " & departHta(i, 3) Application.DisplayAlerts = False Debug.Print departHta(i, 2) & " " & departHta(i, 3) DoEvents ' Arrête momentanément l'exécution afin que le système ' d'exploitation puisse traiter d'autres événements Sleep 40 ' pause de 40 millisecondes 'fichier du départ en cours Fichier = Replace(departHta(i, 2) & " " & departHta(i, 3) & " HTA.txt", "/", "-") RetourDirFich = DirFich(Fichier, repTx & "HTA\") If RetourDirFich = True Then Kill (repTx & "HTA\" & Fichier) Open repTx & "HTA\" & Fichier For Append Shared As #1 'fichier du départ en cours Fichier = Replace(departHta(i, 2) & " " & departHta(i, 3) & " HTA-Aerien.txt", "/", "-") RetourDirFich = DirFich(Fichier, repTx & "HTA_Aerien\") If RetourDirFich = True Then Kill (repTx & "HTA_Aerien\" & Fichier) Open repTx & "HTA_Aerien\" & Fichier For Append Shared As #2 Print #1, "F;T;Lib\HTA\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) Print #2, "F;T;Lib\HTA-Aerien\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) Print #5, "F;T;Lib\HTA\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) ' requete sur la table reseau_HTA Parametres(1) = departHta(i, 2) '& " " & departHta(i, 3) strSql = RqSelect("Requete_HTA", Parametres()) 'Debug.Print strSql Erase segmentHta segmentHta() = rqResultat(strSql) If ValidTraitement = False Then GoTo err If segmentHta(1, 1) = "False" Then Close #1 Close #2 Else For j = 1 To UBound(segmentHta, 1) 'en-tete de tracé If Left(segmentHta(j, 2), 1) = "A" Then Couleur = HTAn Aerien = True End If If Left(segmentHta(j, 2), 1) = "S" Then Couleur = HTAs Aerien = False End If If Left(segmentHta(j, 2), 1) = "T" Then Couleur = HTAt Aerien = True End If Print #1, "T;" & departHta(i, 2) & "-" & Format(segmentHta(j, 1), "000") & ";1;0;" & Couleur & ";65280;" & epaisseurHTA & ";1" If Aerien = True Then Print #2, "T;" & departHta(i, 2) & "-" & Format(segmentHta(j, 1), "000") & ";1;0;" & Couleur & ";65280;" & epaisseurHTA & ";1" Print #5, "T;" & departHta(i, 2) & "-" & Format(segmentHta(j, 1), "000") & ";1;0;" & Couleur & ";65280;" & epaisseurHTA & ";1" strCoord = segmentHta(j, 3) strCoord = Replace(strCoord, "LINESTRING(", "") strCoord = Replace(strCoord, ")", "") Erase coordonnees coordonnees = Split(strCoord, ",") For k = 0 To UBound(coordonnees, 1) Erase point point = Split(coordonnees(k), " ") vLat = CStr(Format(point(1), "0.000000000000000")) vLat = Replace(vLat, ",", ".") vLong = CStr(Format(point(0), "0.000000000000000")) vLong = Replace(vLong, ",", ".") Print #1, "P;" & vLat & ";" & vLong & ";0;-9999;;0.000;00:00:00;0;0.0;-1" If Aerien = True Then Print #2, "P;" & vLat & ";" & vLong & ";0;-9999;;0.000;00:00:00;0;0.0;-1" Print #5, "P;" & vLat & ";" & vLong & ";0;-9999;;0.000;00:00:00;0;0.0;-1" Next k Next j Close #1 Close #2 End If 'génération des WayPoint des IA et des Postes 'fichier du départ en cours Fichier = Replace(departHta(i, 2) & " " & departHta(i, 3) & " IA-Postes.txt", "/", "-") RetourDirFich = DirFich(Fichier, repTx & "IA-Postes\") If RetourDirFich = True Then Kill (repTx & "IA-Postes\" & Fichier) Open repTx & "IA-Postes\" & Fichier For Append Shared As #3 Print #3, "F;W;Lib\IA\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) Print #7, "F;W;Lib\IA\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) Parametres(1) = departHta(i, 2) & " " & departHta(i, 3) strSql = RqSelect("Requete_IA", Parametres()) ia() = rqResultat(strSql) If ValidTraitement = False Then GoTo err If ia(1, 1) = "False" Then Close #3 Else 'j = 1 For j = 1 To UBound(ia, 1) Erase point strCoord = ia(j, 3) strCoord = Replace(strCoord, "POINT(", "") strCoord = Replace(strCoord, ")", "") point = Split(strCoord, " ") vLat = CStr(Format(point(1), "0.000000000000000")) vLat = Replace(vLat, ",", ".") vLong = CStr(Format(point(0), "0.000000000000000")) vLong = Replace(vLong, ",", ".") Print #3, "W;" & ia(j, 1) & ";;" & vLat & ";" & vLong & ";0;" & _ vX & ";" & vY & ";0;C3;LT2;5;0;8351;12;1;5;3;" & _ "Arial Narrow,8,0,0,0,0;16711680;14745599;8;0;1;1;France;1" Print #7, "W;" & ia(j, 1) & ";;" & vLat & ";" & vLong & ";0;" & _ vX & ";" & vY & ";0;C3;LT2;5;0;8351;12;1;5;3;" & _ "Arial Narrow,8,0,0,0,0;16711680;14745599;8;0;1;1;France;1" Next j End If Close #3 ' ouvre un recordset sur la table "Postes" Fichier = Replace(departHta(i, 2) & " " & departHta(i, 3) & " IA-Postes.txt", "/", "-") RetourDirFich = DirFich(Fichier, repTx & "IA-Postes\") Open repTx & "IA-Postes\" & Fichier For Append Shared As #3 Print #3, "F;W;Lib\Postes\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) Print #7, "F;W;Lib\Postes\" & Left(departHta(i, 2), 5) & "\" & departHta(i, 3) Parametres(1) = departHta(i, 2) & " " & departHta(i, 3) strSql = RqSelect("Requete_Postes_HTA", Parametres()) 'Debug.Print strSql poste() = rqResultat(strSql) If ValidTraitement = False Then GoTo err If poste(1, 1) = "False" Then Close #3 Else 'j = 1 For j = 1 To UBound(poste, 1) Erase point strCoord = poste(j, 3) strCoord = Replace(strCoord, "POINT(", "") strCoord = Replace(strCoord, ")", "") point = Split(strCoord, " ") vLat = CStr(Format(point(1), "0.000000000000000")) vLat = Replace(vLat, ",", ".") vLong = CStr(Format(point(0), "0.000000000000000")) vLong = Replace(vLong, ",", ".") If poste(j, 2) = "AB" Then Symbole = "15;10" Else Symbole = "8294;9" End If Print #3, "W;" & poste(j, 1) & ";" & poste(j, 2) & ";" & vLat & ";" & vLong & ";0;" & _ vX & ";" & vY & ";0;C3;LT2;5;0;" & Symbole & ";1;5;3;" & _ "Arial Narrow,8,0,0,0,0;16711680;14745599;8;0;1;1;France;1" Print #7, "W;" & poste(j, 1) & ";" & poste(j, 2) & ";" & vLat & ";" & vLong & ";0;" & _ vX & ";" & vY & ";0;C3;LT2;5;0;" & Symbole & ";1;5;3;" & _ "Arial Narrow,8,0,0,0,0;16711680;14745599;8;0;1;1;France;1" Next j End If Close #3 suite: Next i Close #5 Close #7 End If GoTo err err: ' Fermeture connexion CloseBdd "" End Sub