1. Accueil
  2. Visual Basic / VB.NET
  3. Sources Visual Basic / VB.NET
  4. Sources VBA
  5. Calcul topo sur excel avec fonction vba

Calcul topo sur excel avec fonction vba

Soyez le premier à donner votre avis sur cette source.

Vue 18 975 fois - Téléchargée 5 072 fois

Télécharger le projet
Commenter

Description

Le but de TOPOVB est de faire une grande quantité de calcul topo sur EXCEL.
Calculer des points tous les 10 cm sur un axe routier, axe décalé, ...
Il est donc très pratique en projet routier si l'on dispose de la tabulation de l'axe.
Par simple recopier les cellules vers le bas.
Exemple : =XYG(XS;YS;LC(-2);LC(-1)) ici les cellules XStation et YStation sont nomées.
=XYGDX(L24C2;L24C3;LC(-2);LC(-1)) ici les cellules XStation et YStation sont figées.
=RCX($B$102;$C$102;$D$102;$E$102;$F$102;$G$102;B117) ici les cellules XStation et YStation sont figées.
=XYG(100;500;110;510) ici tout est rempli( résultat = 50 grades).

Liste des fonctions disponibles dans TOPOVB:

= XYG(Xstation, Ystation, Xpoint, Ypoint) Converti des coordonnées rectangulaires en gisement exprimés en Grades.
= XYD(Xstation, Ystation, Xpoint, Ypoint) Converti des coordonnées rectangulaires en distances.
= XYGDX(Xstation, Ystation, GISEMENT, DISTANCE) Converti des coordonnées POLAIRES exprimés en grades en coordonnées X.
= XYGDY(Xstation, Ystation, GISEMENT, DISTANCE) Converti des coordonnées POLAIRES exprimés en grades en coordonnées Y.
= DROITEABSX(AbsDep, Xdep, Ydep, Xfin, Yfin, AbsPoint) Calcul des points intermédiaires sur une droite, donne X.
= DROITEABSY(AbsDep, Xdep, Ydep, Xfin, Yfin, AbsPoint) Calcul des points intermédiaires sur une droite, donne Y.
= IDGX(X_Doite_1, Y_Doite_1, Gisement_Doite_1_Grades, X_Doite_2, Y_Doite_2, Gisement_Doite_2_Grades)
Calcul l'intersection de 2 droites en X en donnant les origines des droites en X/Y et leurs gisements.
= IDGY(X_Doite_1, Y_Doite_1, Gisement_Doite_1_Grades, X_Doite_2, Y_Doite_2, Gisement_Doite_2_Grades)
Calcul l'intersection de 2 droites en Y en donnant les origines des droites en X/Y et leurs gisements.
= ICX(X_Centre_1, Y_Centre_1, R1, X_Centre_2, Y_Centre_2, R2, Solution_D_G)
Calcul l'intersection de 2 CERCLES en X en donnant les CENTRES des CERCLES en X/Y et leurs RAYONS.
= ICY(X_Centre_1, Y_Centre_1, R1, X_Centre_2, Y_Centre_2, R2, Solution_D_G)
Calcul l'intersection de 2 CERCLES en Y en donnant les CENTRES des CERCLES en X/Y et leurs RAYONS.
= RCX(X_Centre, Y_Centre, R_négatif_à_droite, X_Tg_Départ, Y_Tg_Départ, Absisse_Tg_Départ, Absisse_Point)
Calcul un raccordement circulaire en X en donnant le centre,la tangente et sont absisse et l'absisse du point a calculer.
= RCY(X_Centre, Y_Centre, R_négatif_à_droite, X_Tg_Départ, Y_Tg_Départ, Absisse_Tg_Départ, Absisse_Point)
Calcul un raccordement circulaire en Y en donnant le centre,la tangente et sont absisse et l'absisse du point a calculer.
= PIP(Absisse_Tg_A, Z_Tg_A, Pente_en_Tg_A, Absisse_Tg_B, Z_Tg_B, Pente_en_Tg_B, Rayon_négatif_bosse, Absisse_Point)
Calcul le Z d'un point sur une parabole.
= PIPHBX(Absisse_Tg_A, Z_Tg_A, Pente_en_Tg_A, Absisse_Tg_B, Z_Tg_B, Pente_en_Tg_B, Rayon_négatif_bosse)
Calcul l'absisse du point Haut ou point Bas sur une parabole.
= PICX(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Début_DROITE, Y_Début_DROITE, Rayon_négatif_DROITE, Longueur_L, Absisse)
Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'X.
= PICY(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Début_DROITE, Y_Début_DROITE, Rayon_négatif_DROITE, Longueur_L, Absisse)
Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'Y.
= PIC2X(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Tg_Cercle, Y_Tg_Cercle, Rayon_négatif_DROITE, Longueur_L, Absisse)
Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'X.
= PIC2Y(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Tg_Cercle, Y_Tg_Cercle, Rayon_négatif_DROITE, Longueur_L, Absisse)
Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'Y.
= GISAXECLOTH(Gis_droite_Grades, Abs_Tg_DROITE, Abs_Tg_CERCLE, Rayon_négatif_DROITE, Absisse)
Calcul le gisement de l'axe sur une clothoide dos à la droite.
= GISAXECLOTH2(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Tg_Cercle, Y_Tg_Cercle, Abs_Tg_CERCLE, Ray_nég_Droite_DàDr, Absisse)
Calcul le gisement de l'axe sur une clothoide dos à la droite.

Mode opératoire sur EXCEL:
Formules / Insérer une fonction / Catégiries -> Personalisées / Choisir une fonction TOPOVB7 ... / Utiliser la boite de dialogue.

Source / Exemple : 


'Tous droits réservés    Copyright 1997   TOUBIN RICHARD
'L 'utilisateur prend ses responsabilités quant à l'utilisation de ce Programme, à la vérification des résultats.
'L'AUTEUR N'ASSUME AUCUNE GARANTIE DE QUELQUE NATURE ET A QUELQUE TITRE
'QUE CE SOIT EXPLICITE OU IMPLICITE, DE CONFORMITE OU D'ADEQUATION A UN USAGE SPECIFIQUE DU LOGICIEL.
'EN TOUT ETAT DE CAUSE LA RESPONSABILITE DE L'AUTEUR NE POURRA EN AUCUN CAS EXCEDER LE MONTANT EFFECTIVEMENT PAYE POUR L'ACQUISITION DU LOGICIEL.
'Ce logiciel est GRATUIT et peut être redistribué dans sont intégralité et gratuitement
'
'
'
'Remarques / Remercïments / Dons ...       Auteur : richardtoubin@live.fr
'
'
'
'Pour utiliser ce fichier vous pouvez :
'       *Ouvrir ce fichier XLS et utiliser les feuilles tells qu'elles. Dans ce cas si vous distribuez
'ce fichier les fonctions personalisée fonctionneront car elles font parti du fichier.
'       *Séparer le fichier XLA et le charger automatiquement à l'ouverture d'EXCEL.
'Dans ce cas vous pourez utiliser les fonctions personalisées dans n'importe que fichier et feuille EXCEL.
'Par contre si vous enregistrez un fichier qui utilise une de ces fonctions et que vous donnez ce fichier,
'n'oubliez pas de lui fournir aussi le fichier XLA, sans quoi l'appel d'une fonction se soldera par un
'   #NOM? car Excel ne trouvera pas la fonction sur le PC de votre ami.
'Vous pouvez aussi ne fournir que des données avec un copier/colage spécial/coller des valeurs.
'Ou encore enregistrer votre fichier au format CSV.
'
'
'
'
'---------------------------------------------------------------------------------------------
'Début des fonctions personalisées :
'---------------------------------------------------------------------------------------------
' XYG Macro VB
' Macro enregistrée le 16/09/1997 par TOUBIN RICHARD
' Converti des coordonnées rectangulaires en gisement exprimés en Grades.
'

Function XYG(Xstation, Ystation, Xpoint, Ypoint)
Pi = 4 * Atn(1)
    If Ypoint - Ystation = 0 Then
        If Xpoint - Xstation > 0 Then
        XYG = 100
        End If
    End If
    If Xpoint - Xstation = 0 Then
        If Ypoint - Ystation < 0 Then
        XYG = 200
        End If
    End If
    If Ypoint - Ystation = 0 Then
        If Xpoint - Xstation < 0 Then
        XYG = 300
        End If
    End If
    If Ypoint - Ystation > 0 Then
        If Xpoint - Xstation > 0 Then
        XYG = (Atn((Xpoint - Xstation) / (Ypoint - Ystation))) / Pi * 200
        ElseIf Xpoint - Xstation < 0 Then
        'XYG = 300 - (Arctan((Xpoint - Xstation) / (Ypoint - Ystation)) / Pi * 200)
        XYG = 400 + ((Atn((Xpoint - Xstation) / (Ypoint - Ystation)) / Pi * 200))
        ElseIf Xpoint - Xstation = 0 Then
        XYG = 0
        End If
    End If
    If Ypoint - Ystation < 0 Then
        If Xpoint - Xstation > 0 Then
        XYG = 200 + (Atn((Xpoint - Xstation) / (Ypoint - Ystation)) / Pi * 200)
        ElseIf Xpoint - Xstation < 0 Then
        XYG = 200 + (Atn((Xpoint - Xstation) / (Ypoint - Ystation)) / Pi * 200)
        End If
    End If
End Function

'---------------------------------------------------------------------------------------------
' XYD Macro VB
' Macro enregistrée le 16/09/1997 par TOUBIN RICHARD
' Converti des coordonnées rectangulaires en distances.
'

Function XYD(Xstation, Ystation, Xpoint, Ypoint)
XYD = Sqr((Xpoint - Xstation) ^ 2 + (Ypoint - Ystation) ^ 2)
End Function

'---------------------------------------------------------------------------------------------
' XYGDX Macro VB
' Macro enregistrée le 16/09/1997 par TOUBIN RICHARD
' Converti des coordonnées POLAIRES exprimés en grades en coordonnées X.
'
Function XYGDX(Xstation, Ystation, GISEMENT, DISTANCE)
Pi = 4 * Atn(1)
XYGDX = Xstation + (DISTANCE * Sin(GISEMENT / 200 * Pi))
End Function

'---------------------------------------------------------------------------------------------
' XYGDY Macro VB
' Macro enregistrée le 16/09/1997 par TOUBIN RICHARD
' Converti des coordonnées POLAIRES exprimés en grades en coordonnées Y.
'
Function XYGDY(Xstation, Ystation, GISEMENT, DISTANCE)
Pi = 4 * Atn(1)
XYGDY = Ystation + (DISTANCE * Cos(GISEMENT / 200 * Pi))
End Function

'---------------------------------------------------------------------------------------------
' DROITEABSX Macro VB
' Macro enregistrée le 16/09/1997 par TOUBIN RICHARD
' Calcul des points intermédiaires sur une droite.
' Les absisse sont considérés croissants du départ vers la fin.

Function DROITEABSX(AbsDep, Xdep, Ydep, Xfin, Yfin, AbsPoint)
Pi = 4 * Atn(1)
If XYD(Xdep, Ydep, Xfin, Yfin) = 0 Then
   DROITEABSX = 0
Else: DROITEABSX = XYGDX(Xdep, Ydep, XYG(Xdep, Ydep, Xfin, Yfin), AbsPoint - AbsDep)
End If
End Function

'---------------------------------------------------------------------------------------------
' DROITEABSY Macro VB
' Macro enregistrée le 16/09/1997 par TOUBIN RICHARD
' Calcul des points intermédiaires sur une droite.
' Les absisses sont considérés croissants du départ vers la fin.

Function DROITEABSY(AbsDep, Xdep, Ydep, Xfin, Yfin, AbsPoint)
Pi = 4 * Atn(1)
If XYD(Xdep, Ydep, Xfin, Yfin) = 0 Then
   DROITEABSY = 0
Else: DROITEABSY = XYGDY(Xdep, Ydep, XYG(Xdep, Ydep, Xfin, Yfin), AbsPoint - AbsDep)
End If
End Function

'---------------------------------------------------------------------------------------------
' IDGX Macro VB
' Macro enregistrée le 19/09/1997 par TOUBIN RICHARD
' Calcul l'intersection de 2 droites en X en donnant les origines des droites en X/Y
' et leurs gisements.
Function IDGX(X_Doite_1, Y_Doite_1, Gisement_Doite_1_Grades, X_Doite_2, Y_Doite_2, Gisement_Doite_2_Grades)
Pi = 4 * Atn(1)
G1 = Gisement_Doite_1_Grades / 200 * Pi
G2 = Gisement_Doite_2_Grades / 200 * Pi
G3 = XYG(X_Doite_2, Y_Doite_2, X_Doite_1, Y_Doite_1) / 200 * Pi
DAB = XYD(X_Doite_1, Y_Doite_1, X_Doite_2, Y_Doite_2)
LM = (Sin(G2 - G3) * DAB) / Cos(G1 - (G2 + (Pi / 2)))
IDGX = XYGDX(X_Doite_1, Y_Doite_1, G1 / Pi * 200, LM)
End Function

'---------------------------------------------------------------------------------------------
' IDGY Macro VB
' Macro enregistrée le 19/09/1997 par TOUBIN RICHARD
' Calcul l'intersection de 2 droites en Y en donnant les origines des droites en X/Y
' et leurs gisements.
Function IDGY(X_Doite_1, Y_Doite_1, Gisement_Doite_1_Grades, X_Doite_2, Y_Doite_2, Gisement_Doite_2_Grades)
Pi = 4 * Atn(1)
G1 = Gisement_Doite_1_Grades / 200 * Pi
G2 = Gisement_Doite_2_Grades / 200 * Pi
G3 = XYG(X_Doite_2, Y_Doite_2, X_Doite_1, Y_Doite_1) / 200 * Pi
DAB = XYD(X_Doite_1, Y_Doite_1, X_Doite_2, Y_Doite_2)
LM = (Sin(G2 - G3) * DAB) / Cos(G1 - (G2 + (Pi / 2)))
IDGY = XYGDY(X_Doite_1, Y_Doite_1, G1 / Pi * 200, LM)
End Function

'---------------------------------------------------------------------------------------------
' ICX Macro VB
' Macro enregistrée le 22/09/1997 par TOUBIN RICHARD
' Calcul l'intersection de 2 CERCLES en X en donnant les CENTRES des CERCLES en X/Y
' et leurs RAYONS.

Function ICX(X_Centre_1, Y_Centre_1, R1, X_Centre_2, Y_Centre_2, R2, Solution_D_G)
Pi = 4 * Atn(1)
DCC = XYD(X_Centre_1, Y_Centre_1, X_Centre_2, Y_Centre_2)
C1H = ((DCC * DCC) + (R1 * R1) - (R2 * R2)) / (2 * DCC)
HI = Sqr((R1 * R1) - (C1H * C1H))
Alpha = Atn(HI / C1H) / Pi * 200
GCC = XYG(X_Centre_1, Y_Centre_1, X_Centre_2, Y_Centre_2)
    If Solution_D_G = "D" Then
        ICX = XYGDX(X_Centre_1, Y_Centre_1, GCC + Alpha, R1)
        ElseIf Solution_D_G = "G" Then
        ICX = XYGDX(X_Centre_1, Y_Centre_1, GCC - Alpha, R1)
    End If
End Function

'---------------------------------------------------------------------------------------------
' ICY Macro VB
' Macro enregistrée le 22/09/1997 par TOUBIN RICHARD
' Calcul l'intersection de 2 CERCLES en Y en donnant les CENTRES des CERCLES en X/Y
' et leurs RAYONS.

Function ICY(X_Centre_1, Y_Centre_1, R1, X_Centre_2, Y_Centre_2, R2, Solution_D_G)
Pi = 4 * Atn(1)
DCC = XYD(X_Centre_1, Y_Centre_1, X_Centre_2, Y_Centre_2)
C1H = ((DCC * DCC) + (R1 * R1) - (R2 * R2)) / (2 * DCC)
HI = Sqr((R1 * R1) - (C1H * C1H))
Alpha = Atn(HI / C1H) / Pi * 200
GCC = XYG(X_Centre_1, Y_Centre_1, X_Centre_2, Y_Centre_2)
    If Solution_D_G = "D" Then
        ICY = XYGDY(X_Centre_1, Y_Centre_1, GCC + Alpha, R1)
        ElseIf Solution_D_G = "G" Then
        ICY = XYGDY(X_Centre_1, Y_Centre_1, GCC - Alpha, R1)
    End If
End Function

'---------------------------------------------------------------------------------------------
' RCX Macro VB
' Macro enregistrée le 25/09/1997 par TOUBIN RICHARD
' Calcul un raccordement circulaire en X en donnant le centre,la tangente et sont
' absisse et l'absisse du point a calculer.

Function RCX(X_Centre, Y_Centre, R_négatif_à_droite, X_Tg_Départ, Y_Tg_Départ, Absisse_Tg_Départ, Absisse_Point)
Pi = 4 * Atn(1)
G = XYG(X_Centre, Y_Centre, X_Tg_Départ, Y_Tg_Départ)
L = Absisse_Point - Absisse_Tg_Départ
RCX = XYGDX(X_Centre, Y_Centre, G + ((200 * L) / (-Pi * R_négatif_à_droite)), Abs(R_négatif_à_droite))
End Function

'---------------------------------------------------------------------------------------------
' RCY Macro VB
' Macro enregistrée le 25/09/1997 par TOUBIN RICHARD
' Calcul un raccordement circulaire en Y en donnant le centre,la tangente et sont
' absisse et l'absisse du point a calculer.

Function RCY(X_Centre, Y_Centre, R_négatif_à_droite, X_Tg_Départ, Y_Tg_Départ, Absisse_Tg_Départ, Absisse_Point)
Pi = 4 * Atn(1)
G = XYG(X_Centre, Y_Centre, X_Tg_Départ, Y_Tg_Départ)
L = Absisse_Point - Absisse_Tg_Départ
RCY = XYGDY(X_Centre, Y_Centre, G + ((200 * L) / (-Pi * R_négatif_à_droite)), Abs(R_négatif_à_droite))
End Function

'---------------------------------------------------------------------------------------------
' PIP Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul le Z d'un point sur une parabole.

Function PIP(Absisse_Tg_A, Z_Tg_A, Pente_en_Tg_A, Absisse_Tg_B, Z_Tg_B, Pente_en_Tg_B, Rayon_négatif_bosse, Absisse_Point)
PA = Pente_en_Tg_A / 100
PB = Pente_en_Tg_B / 100
W = Absisse_Tg_B - Absisse_Tg_A
Q = W * PA
U = Z_Tg_A + Q
P = U - Z_Tg_B
t = W * (-PB)
H = Z_Tg_B + t
I = (H) - (Z_Tg_A)
HB = (W * P) / (I + P)
HA = W - HB
XS = Absisse_Tg_A + HA
ZS = Z_Tg_B - (HB * PB)
E = Rayon_négatif_bosse * PA
u_F = Rayon_négatif_bosse * PB
L = u_F - E
TE = L / 2
G = XS - TE
Y = XS + TE
m = ZS + (TE * (-PA))
V = ZS + (TE * PB)
XO = G - E
N = (Rayon_négatif_bosse / 2) * (PA * PA)
O = m - N
X = Absisse_Point - XO
Y2 = (X * X) / (2 * Rayon_négatif_bosse)
Z = O + Y2
PIP = Z
End Function

'---------------------------------------------------------------------------------------------
' PIPHBX Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul l'absisse du point Haut ou point Bas sur une parabole.

Function PIPHBX(Absisse_Tg_A, Z_Tg_A, Pente_en_Tg_A, Absisse_Tg_B, Z_Tg_B, Pente_en_Tg_B, Rayon_négatif_bosse)
PA = Pente_en_Tg_A / 100
PB = Pente_en_Tg_B / 100
W = Absisse_Tg_B - Absisse_Tg_A
Q = W * PA
U = Z_Tg_A + Q
P = U - Z_Tg_B
t = W * (-PB)
H = Z_Tg_B + t
I = (H) - (Z_Tg_A)
HB = (W * P) / (I + P)
HA = W - HB
XS = Absisse_Tg_A + HA
E = Rayon_négatif_bosse * PA
u_F = Rayon_négatif_bosse * PB
L = u_F - E
TE = L / 2
G = XS - TE
XO = G - E
PIPHBX = XO
End Function

'---------------------------------------------------------------------------------------------
' PICX Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'X.

Function PICX(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Début_DROITE, Y_Début_DROITE, Rayon_négatif_DROITE, Longueur_L, Absisse)
Pi = 4 * Atn(1)
L = Longueur_L
R = Rayon_négatif_DROITE
AP = Sqr(Abs(R * L))
XA = (L - ((L ^ 5) / (40 * (AP ^ 4)))) + ((L ^ 9) / (3456 * (AP ^ 8)))
YA = ((L ^ 3) / (6 * (AP ^ 2))) - ((L ^ 7) / (336 * (AP ^ 6))) + ((L ^ 11) / (42240 * (AP ^ 10)))
'Calcul du gisement GD en RADIAN de la droite
GD = XYG(X_Début_DROITE, Y_Début_DROITE, X_Tg_Droite, Y_Tg_Droite) / 200 * Pi
'Calcul d'un point intermédiaire.
LP = Abs(Absisse - Abs_Tg_DROITE)
XB = (LP - ((LP ^ 5) / (40 * (AP ^ 4)))) + ((LP ^ 9) / (3456 * (AP ^ 8)))
YB = ((LP ^ 3) / (6 * (AP ^ 2))) - ((LP ^ 7) / (336 * (AP ^ 6))) + ((LP ^ 11) / (42240 * (AP ^ 10)))
XO = X_Tg_Droite
If R < 0 Then
    X = XO + (XB * (Sin(GD))) + (YB * (Cos(GD)))
    Else: X = XO + (XB * (Sin(GD))) - (YB * (Cos(GD)))
End If
PICX = X
End Function

'---------------------------------------------------------------------------------------------
' PICY Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'Y.

Function PICY(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Début_DROITE, Y_Début_DROITE, Rayon_négatif_DROITE, Longueur_L, Absisse)
Pi = 4 * Atn(1)
L = Longueur_L
R = Rayon_négatif_DROITE
AP = Sqr(Abs(R * L))
XA = (L - ((L ^ 5) / (40 * (AP ^ 4)))) + ((L ^ 9) / (3456 * (AP ^ 8)))
YA = ((L ^ 3) / (6 * (AP ^ 2))) - ((L ^ 7) / (336 * (AP ^ 6))) + ((L ^ 11) / (42240 * (AP ^ 10)))
'Calcul du gisement GD en RADIAN de la droite
GD = XYG(X_Début_DROITE, Y_Début_DROITE, X_Tg_Droite, Y_Tg_Droite) / 200 * Pi
'Calcul d'un point intermédiaire.
LP = Abs(Absisse - Abs_Tg_DROITE)
XB = (LP - ((LP ^ 5) / (40 * (AP ^ 4)))) + ((LP ^ 9) / (3456 * (AP ^ 8)))
YB = ((LP ^ 3) / (6 * (AP ^ 2))) - ((LP ^ 7) / (336 * (AP ^ 6))) + ((LP ^ 11) / (42240 * (AP ^ 10)))
YO = Y_Tg_Droite
If R < 0 Then
    Y = YO + (XB * (Cos(GD))) - (YB * (Sin(GD)))
    Else: Y = YO + (XB * (Cos(GD))) + (YB * (Sin(GD)))
End If
PICY = Y
End Function

'---------------------------------------------------------------------------------------------
' PIC2X Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'X.

Function PIC2X(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Tg_Cercle, Y_Tg_Cercle, Rayon_négatif_DROITE, Longueur_L, Absisse)
Pi = 4 * Atn(1)
L = Longueur_L
R = Rayon_négatif_DROITE
AP = Sqr(Abs(R * L))
XA = (L - ((L ^ 5) / (40 * (AP ^ 4)))) + ((L ^ 9) / (3456 * (AP ^ 8)))
YA = ((L ^ 3) / (6 * (AP ^ 2))) - ((L ^ 7) / (336 * (AP ^ 6))) + ((L ^ 11) / (42240 * (AP ^ 10)))
'Calcul du gisement G2 en radian de la Tg à la droite vers la Tg au cercle
G2 = XYG(X_Tg_Droite, Y_Tg_Droite, X_Tg_Cercle, Y_Tg_Cercle) / 200 * Pi
'Calcul du gisement GD en radian de la droite
Alpha = (Pi / 2) - (Atn(XA / YA))
If R < 0 Then
    GD = G2 - Alpha
    Else: GD = G2 + Alpha
End If
'Calcul d'un point intermédiaire.
LP = Abs(Absisse - Abs_Tg_DROITE)
XB = (LP - ((LP ^ 5) / (40 * (AP ^ 4)))) + ((LP ^ 9) / (3456 * (AP ^ 8)))
YB = ((LP ^ 3) / (6 * (AP ^ 2))) - ((LP ^ 7) / (336 * (AP ^ 6))) + ((LP ^ 11) / (42240 * (AP ^ 10)))
XO = X_Tg_Droite
If R < 0 Then
    X = XO + (XB * (Sin(GD))) + (YB * (Cos(GD)))
    Else: X = XO + (XB * (Sin(GD))) - (YB * (Cos(GD)))
End If
PIC2X = X
End Function

'---------------------------------------------------------------------------------------------
' PIC2Y Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul des points intermédiaires sur une CLOTHOIDE et renvoi l'Y.

Function PIC2Y(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Tg_Cercle, Y_Tg_Cercle, Rayon_négatif_DROITE, Longueur_L, Absisse)
Pi = 4 * Atn(1)
L = Longueur_L
R = Rayon_négatif_DROITE
AP = Sqr(Abs(R * L))
XA = (L - ((L ^ 5) / (40 * (AP ^ 4)))) + ((L ^ 9) / (3456 * (AP ^ 8)))
YA = ((L ^ 3) / (6 * (AP ^ 2))) - ((L ^ 7) / (336 * (AP ^ 6))) + ((L ^ 11) / (42240 * (AP ^ 10)))
'Calcul du gisement G2 en radian de la Tg à la droite vers la Tg au cercle
G2 = XYG(X_Tg_Droite, Y_Tg_Droite, X_Tg_Cercle, Y_Tg_Cercle) / 200 * Pi
'Calcul du gisement GD en radian de la droite
Alpha = (Pi / 2) - (Atn(XA / YA))
If R < 0 Then
    GD = G2 - Alpha
    Else: GD = G2 + Alpha
End If
'Calcul d'un point intermédiaire.
LP = Abs(Absisse - Abs_Tg_DROITE)
XB = (LP - ((LP ^ 5) / (40 * (AP ^ 4)))) + ((LP ^ 9) / (3456 * (AP ^ 8)))
YB = ((LP ^ 3) / (6 * (AP ^ 2))) - ((LP ^ 7) / (336 * (AP ^ 6))) + ((LP ^ 11) / (42240 * (AP ^ 10)))
YO = Y_Tg_Droite
If R < 0 Then
    Y = YO + (XB * (Cos(GD))) - (YB * (Sin(GD)))
    Else: Y = YO + (XB * (Cos(GD))) + (YB * (Sin(GD)))
End If
PIC2Y = Y
End Function

'---------------------------------------------------------------------------------------------
' GISAXECLOTH Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul le gisement de l'axe sur une clothoide dos à la droite.
Function GISAXECLOTH(Gis_droite_Grades, Abs_Tg_DROITE, Abs_Tg_CERCLE, Rayon_négatif_DROITE, Absisse)
Pi = 4 * Atn(1)
L = Abs(Abs_Tg_CERCLE - Abs_Tg_DROITE)
RC = Rayon_négatif_DROITE
AC = Sqr(Abs(RC * L))
LP = Abs(Absisse - Abs_Tg_DROITE)
If LP = 0 Then
    TETA = 0
    Else: RP = (AC ^ 2) / LP
          TETA = LP / (2 * RP) 'en radians
End If

If RC < 0 Then
     GISCLOT = (Gis_droite_Grades / 200 * Pi) + TETA 'en radians
    Else: GISCLOT = (Gis_droite_Grades / 200 * Pi) - TETA 'en radians
End If

GISAXECLOTH = 400 - (GISCLOT / Pi * 200)
If GISAXECLOTH >= 400 Then
GISAXECLOTH = GISAXECLOTH - 400
End If
If GISAXECLOTH < 0 Then
GISAXECLOTH = GISAXECLOTH + 400
End If
End Function

'---------------------------------------------------------------------------------------------
' GISAXECLOTH2 Macro VB
' Macro enregistrée le 29/09/1997 par TOUBIN RICHARD
' Calcul le gisement de l'axe sur une clothoide dos à la droite.
Function GISAXECLOTH2(X_Tg_Droite, Y_Tg_Droite, Abs_Tg_DROITE, X_Tg_Cercle, Y_Tg_Cercle, Abs_Tg_CERCLE, Ray_nég_Droite_DàDr, Absisse)
Pi = 4 * Atn(1)
L = Abs_Tg_CERCLE - Abs_Tg_DROITE
R = Ray_nég_Droite_DàDr
AP = Sqr(Abs(R * L))
XA = (L - ((L ^ 5) / (40 * (AP ^ 4)))) + ((L ^ 9) / (3456 * (AP ^ 8)))
YA = ((L ^ 3) / (6 * (AP ^ 2))) - ((L ^ 7) / (336 * (AP ^ 6))) + ((L ^ 11) / (42240 * (AP ^ 10)))
'Calcul du gisement G2 en radian de la Tg à la droite vers la Tg au cercle
G2 = XYG(X_Tg_Droite, Y_Tg_Droite, X_Tg_Cercle, Y_Tg_Cercle) / 200 * Pi
'Calcul du gisement GD en radian de la droite
Alpha = (Pi / 2) - (Atn(XA / YA))
'----------------------------------------------
If R < 0 Then
    GD = G2 - Alpha
    Else: GD = G2 + Alpha
End If
RC = Ray_nég_Droite_DàDr
AC = Sqr(Abs(R * L))
LP = Abs(Absisse - Abs_Tg_DROITE)
If LP = 0 Then
    TETA = 0
    Else: RP = (AC ^ 2) / LP
          TETA = (LP / (2 * RP)) 'en radians
End If
If RC < 0 Then
    GISAXECLOTH2 = (GD + TETA) / Pi * 200
    Else: GISAXECLOTH2 = (GD - TETA) / Pi * 200
End If
If L < 0 Then
    GISAXECLOTH2 = GISAXECLOTH2 + 200
End If
If GISAXECLOTH2 >= 400 Then
    GISAXECLOTH2 = GISAXECLOTH2 - 400
End If
If GISAXECLOTH2 < 0 Then
    GISAXECLOTH2 = GISAXECLOTH2 + 400
End If

GISAXECLOTH2 = 400 - GISAXECLOTH2
End Function

Conclusion :


Util en calul topo, notement en projet
Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire Commentaires
richardt
9 déc. 2012 à 23:09
Merci à toi US_30 pour tes conseils...
Je les ai suivi et du coup, merci aux divers admins qui mon aidé pour alléger les divers répertoires qui sont créé par VB2010 et autre.
Alors voila TXTCSVversDXF et c'est ici:
http://www.vbfrance.com/codes/CSVTXTVERSDXF_54780.aspx
et yora toujours autant d'fautes,malheureusement ...
us_30
Messages postés
2065
Date d'inscription
lundi 11 avril 2005
Statut
Membre
Dernière intervention
14 mars 2016
 10
23 nov. 2012 à 19:10
Bonsoir,

ETNIQS ne soit pas mauvaise langue :); des fautes on en fait tous avec la fatigue ou la rapidité. De plus, si tu lis les REM, tu pourras remarquer une marque de fabrique de l'auteur :);

RICHARDT, pour tes codes sur les conversions de fichier Dessin aux format DXF ou SCR, je pense qu'ils devraient tenir dans le site sans problème. Bien sur, l'exécutable n'est pas autorisé (comme à ses débuts) pour éviter la propagation de virus. Au pire, tu peux contacter les Administrateurs pour exposer ton problème, ils seront, à mon avis, attentif à ton problème et trouveront une solution. (Utilise le menu du site Accueil>Aide & règlement> Contacter les Admins). Mais 17 Mo de code me semble excessivement volumineux. Il y a surement qlq chose qui doit t’échapper. Pour VB2010, tous les sous-dossiers du projet ne sont pas nécessaires. Seuls les fichiers qui sont à la racine de ton projet et le sous-dossier Ressources s'il contient qlq chose sont utiles.

Amicalement,
Us.
cs_etniqs
Messages postés
201
Date d'inscription
mardi 7 octobre 2003
Statut
Membre
Dernière intervention
10 mai 2016
23 nov. 2012 à 10:02
C'est quand même bizarre toutes ces fautes d'orthographe ... pour un code aussi précis.

Mais bon cela permet de prouver que le code est bien celui de l'auteur présumé ;-)
richardt
14 nov. 2012 à 01:51
bonsoir us_30,
c'est effectivement un copier/coller d'un de mes vieux code et j'ai simplement pris soin de rajouter la petite phrase
'Ce logiciel est GRATUIT et peut être redistribué dans sont intégralité et gratuitement
Mon nouveau "droit réservé"...c'est pas mal non?
J'aurais effectivement pu prendre soin de supprimer cette phrase, mais c'est un vieux code que j'ai mis ici sur la demande de confrères et je ne l'ai pas relu.
Ce code est donc de fait effectivement partagé et pour te rassurer il est bien de moi.
Pour une foie qu’il y a un boue de code concernant la topographie sur VBF, je suis plutôt dessus de cet accueil, mais je reconnais que le bon droit … c’est très bien.
Par ailleurs je n’ai pas pu mettre en ligne des codes plus volumineux sur VBF, on m’avait notamment demandé un code sur une conversion de fichier du type TXT CSV vers DXF ou SCR adapté aux géomètres, incluant le dessin automatique. J’ai pu mettre l’exe en ligne sur un autre site mais il me paraît plus intéressant de mettre le code. Y a-t-il un moyen sur VBF? Le projet fait 17 Mo, il est en Visual Basique 2010. J’aurai plusieurs code dans le genre.
Pourriez vous m’aiguiller ??? merci d'avance.
En tous cas merci à us_30 d’avoir prêté attention à ce code.
us_30
Messages postés
2065
Date d'inscription
lundi 11 avril 2005
Statut
Membre
Dernière intervention
14 mars 2016
 10
13 nov. 2012 à 20:57
bonsoir,

Tes petites fonctions sont intéressantes. Mais... dans un site de partage, comme VBF, la mention "'Tous droits réservés Copyright 1997" n'est pas possible. J'espère que ce n'est qu'un malheureux copier/coller, et que tu sois bien l'auteur.

Amicalement,
Us.
S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_richardt)