Le portail francophone de la géomatique

Option Explicit
Dim zoom As Integer
Dim reponse As String

Dim nombredepointsdxf As Integer
Dim nombredepointsSystèmeArrivée As Integer
Dim ChoisirPointsSystèmeArrivée As Integer
'déclarations des  tableaux de points
'POINTS DU DXF
Dim pointDXFx(1 To 2000)
Dim pointDXFy(1 To 2000)
'points cliqués sur le SCAN
Dim pointSCANx(1 To 2000)
Dim pointSCANy(1 To 2000)
'points transformés
Dim pointtransformex(1 To 2000)
Dim pointtransformey(1 To 2000)

Dim pointx(1 To 2000)
Dim pointy(1 To 2000)

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer

Private Sub Form_Load()
zoom = 1
nombredepointsdxf = 0
i = 1
nombredepointsSystèmeArrivée = 0
ChoisirPointsSystèmeArrivée = 0
End Sub


'*****************************************************TRANSFORMATION D'HELMERT*****************************************************************'
Private Sub Ouvrir_Fichier_Points_DXF_Click()
'on efface les points sur la pictureBox picdest
PicDEST.Cls
'******************************************************************************************************************'
'LE PRINCIPE d'un fichier DXF de points quand on l'ouvre avec WORDPAD OU LE BLOCNOTE :
'ACDbPoint
'10
'1.1646 ------------> correspond à la coordonnées X1
'10
'6.5155 ------------> correspond à la coordonnées Y1
'etc....
'ACDbPoint
'10
'1.1646 ------------> correspond à la coordonnées X2
'10
'6.5155 ------------> correspond à la coordonnées Y2
'etc....
'ACDbPoint
'10
'5.2223 ------------> correspond à la coordonnées Xn
'10
'10.3256 ------------> correspond à la coordonnées Yn
'******************************************************************************************************************'
'le pincipe : on va lire tout le fichier et on s'arrête quand on a la valeur ACDbPoint
'on prends alors la 2ème ligne et la 4ème ligne après ACDbPoint qui correspondent
'aux coordonnées X1 et Y1 du premier point et ainsi de suite jusqu'au point Xn et Yn'
'******************************************************************************************************************'
dlgCommonDialog.CancelError = True
On Error GoTo ErrHandler
dlgCommonDialog.Flags = cdlOFNHideReadOnly
dlgCommonDialog.Filter = "Texte(*.txt)|*.txt"
dlgCommonDialog.ShowOpen
Open dlgCommonDialog.FileName For Input As #1
Dim MyString
i = 1
nombredepointsdxf = 0
Do While Not EOF(1)   ' Effectue la boucle jusqu'à la fin du fichier.
Input #1, MyString
If MyString = "ACDbPoint" Then 'on sait qu'il y a un point de défini dans le DXF
'on veut aller lire la 2ème ligne et la 4ème ligne après ACDbPoint'
Input #1, MyString 'on passe une ligne'
Input #1, MyString 'on est sur la 2ème ligne après ACDbPoint'
pointDXFx(i) = MyString 'on charge donc la coordonnée X1 dans le tableau'
Input #1, MyString 'on passe une ligne'
Input #1, MyString 'on est sur la 4ème ligne après ACDbPoint'
pointDXFy(i) = MyString 'on charge donc la coordonnée Y1 dans le tableau'
End If
i = i + 1
'on incrémente le nombre de points contenus dans le fichier'
nombredepointsdxf = nombredepointsdxf + 1
If nombredepointsdxf = 0 Then
'on ne créé pas de texte
Else
'au préalable : tous les textes ou label doivent exister et être d'indice 0 (TxtDXFX(0),TxtDXFY(0),LblpointDXF(0))
'on crée le nombre de texte et de label selon le nombre de points contenus dans le dxf
Dim iNewItem As Integer
    'Trouver l'index à créer
    iNewItem = TxtDXFX.UBound + 1
    'Créer le nouveau contôle TxtDXFX et le positionner
    Load TxtDXFX(iNewItem)
    TxtDXFX(iNewItem).Top = TxtDXFX(iNewItem - 1).Top + TxtDXFX(iNewItem - 1).Height
    TxtDXFX(iNewItem).Left = TxtDXFX(iNewItem - 1).Left
    TxtDXFX(iNewItem).Visible = True
    TxtDXFX(iNewItem).Text = pointDXFx(iNewItem)
Dim jNewItem As Integer
    'Trouver l'index à créer
    jNewItem = TxtDXFY.UBound + 1
    'Créer le nouveau contôle TxtDXFY et le positionner
    Load TxtDXFY(jNewItem)
    TxtDXFY(jNewItem).Top = TxtDXFY(jNewItem - 1).Top + TxtDXFY(jNewItem - 1).Height
    TxtDXFY(jNewItem).Left = TxtDXFY(jNewItem - 1).Left
    TxtDXFY(jNewItem).Visible = True
    TxtDXFY(jNewItem).Text = pointDXFy(jNewItem)
Dim kNewItem As Integer
    'Trouver l'index à créer
    kNewItem = LblpointDXF.UBound + 1
    'Créer le nouveau contôle LblpointDXF et le positionner
    Load LblpointDXF(kNewItem)
    LblpointDXF(kNewItem).Top = LblpointDXF(kNewItem - 1).Top + LblpointDXF(kNewItem - 1).Height
    LblpointDXF(kNewItem).Left = LblpointDXF(kNewItem - 1).Left
    LblpointDXF(kNewItem).Caption = "Point" & kNewItem & ":"
    LblpointDXF(kNewItem).Visible = True
End If
'on affiche le nombre de points contenus dans le dxf dans le texte suivant
TxtnombredepointsDXF.Text = i - 1
Loop
Close #1   ' Ferme le fichier.
'on appelle la fonction qui va dessiner les points sur la pictureBOX
Call AFFICHERPOINTSDUDXFSURPICTURE
'une fois le fichier ouvert on peut demander à l' utilisateur de choisir les coordonnées du système d'arrivée
'********************************************************************************************************************************'
reponse = MsgBox("les Points du fichier DXF sont chargés (il peuvent être non visibles ),Veuillez Choisir les Points du Système d'Arrivée en les Cliquant consécutivement sur le Plan Scanné", vbYesNo)
'********************************************************************************************************************************'
If reponse = vbYes Then
'********************************************************************************************************************************'
'l'utilisateur doit maintenant cliquer le même nombre de points sur la picturebox
'pour charger les points -> Private Sub Picdest_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'********************************************************************************************************************************'
'on initialise le nombredepointsSystèmeArrivée
nombredepointsSystèmeArrivée = 0
'on reset le nombre de points
TxtnombredepointsSCAN.Text = 0
ChoisirPointsSystèmeArrivée = 1
'la frame nous permet d'afficher tous les points du dxf dans des textes,d'afficher tout les points cliqués sur le scan,d'afficher
'tout les points transformés et les paramètres a,b,p,q de la transformation d'helmert
frmChoisirPointsSystèmeArrivée.Top = 0
frmChoisirPointsSystèmeArrivée.Left = 0
frmChoisirPointsSystèmeArrivée.Visible = True
End If
If reponse = vbNo Then
ChoisirPointsSystèmeArrivée = 0
frmChoisirPointsSystèmeArrivée.Visible = False
End If
CBLANCERCALCULHELMERT.Visible = True
ErrHandler:

Exit Sub
End Sub

Private Sub Picdest_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ChoisirPointsSystèmeArrivée = 1 Then
'nota :nombredepointsSystèmeArrivée est à 0 au démarrage
nombredepointsSystèmeArrivée = nombredepointsSystèmeArrivée + 1
'au préalable : tous les textes ou label doivent exister et être d'indice 0 (Txtscanx(0),Txtscany(0),Lblpointscan(0))
'on crée le nombre de texte et de label selon le nombre de points qu'on va cliquer sur le scan contenue dans la pictureBOX Picdest
Dim iNewItem As Integer
    'Trouver l'index à créer
    iNewItem = Txtscanx.UBound + 1
    'Créer le nouveau contôle Txtscanx et le positionner
    Load Txtscanx(iNewItem)
    Txtscanx(iNewItem).Top = Txtscanx(iNewItem - 1).Top + Txtscanx(iNewItem - 1).Height
    Txtscanx(iNewItem).Left = Txtscanx(iNewItem - 1).Left
    Txtscanx(iNewItem).Visible = True
Dim jNewItem As Integer
    'Trouver l'index à créer
    jNewItem = Txtscany.UBound + 1
    'Créer le nouveau contôle Txtscany et le positionner
    Load Txtscany(jNewItem)
    Txtscany(jNewItem).Top = Txtscany(jNewItem - 1).Top + Txtscany(jNewItem - 1).Height
    Txtscany(jNewItem).Left = Txtscany(jNewItem - 1).Left
    Txtscany(jNewItem).Visible = True
Dim kNewItem As Integer
    'Trouver l'index à créer
    kNewItem = Lblpointscan.UBound + 1
    'Créer le nouveau contôle Lblpointscan et le positionner
    Load Lblpointscan(kNewItem)
    Lblpointscan(kNewItem).Top = Lblpointscan(kNewItem - 1).Top + Lblpointscan(kNewItem - 1).Height
    Lblpointscan(kNewItem).Left = Lblpointscan(kNewItem - 1).Left
    Lblpointscan(kNewItem).Caption = "Point" & kNewItem & ":"
    Lblpointscan(kNewItem).Visible = True
   
'on affiche le nombre de points cliqués sur le scan dans le texte suivant
TxtnombredepointsSCAN.Text = nombredepointsSystèmeArrivée
'on charge les coordonnées des points cliqués sur le scan et on les affichent dans les textes sur la frame frmChoisirPointsSystèmeArrivée
Txtscanx(nombredepointsSystèmeArrivée).Text = X / zoom
Txtscany(nombredepointsSystèmeArrivée).Text = Y / zoom
'on charge les coordonnées des points cliqués sur le scan dans les tableaux
pointSCANx(nombredepointsSystèmeArrivée) = X / zoom
pointSCANy(nombredepointsSystèmeArrivée) = Y / zoom
'***************************************************************************************************************************'
'on affiche ces points cliqués sur le scan en appelant la procédure
Call AFFICHERPOINTSDUSYSTEMEARRIVEESURPICTURE
'***************************************************************************************************************************'
If nombredepointsSystèmeArrivée = nombredepointsdxf Then
CBLANCERCALCULHELMERT.Visible = True
MsgBox "vous pouvez lancer la transformation d'HELMERT"
End If
End If
End Sub
Private Sub Picdest_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
TextPICDESTX.Text = X / zoom
TextPICDESTY.Text = Y / zoom
TextPICDESTXREEL = X
TextPICDESTYREEL = Y
End Sub

Sub AFFICHERPOINTSDUSYSTEMEARRIVEESURPICTURE()
'on dessine les points cliqués sur le scan en vert
PicDEST.PSet (pointSCANx(nombredepointsSystèmeArrivée) * zoom, pointSCANy(nombredepointsSystèmeArrivée) * zoom), QBColor(4)
'on dessine les repères verticaux et horizontaux des points
PicDEST.Line (pointSCANx(nombredepointsSystèmeArrivée) * zoom, pointSCANy(nombredepointsSystèmeArrivée) * zoom - 4)-(pointSCANx(nombredepointsSystèmeArrivée) * zoom, pointSCANy(nombredepointsSystèmeArrivée) * zoom + 4), RGB(0, 255, 0)
PicDEST.Line (pointSCANx(nombredepointsSystèmeArrivée) * zoom - 4, pointSCANy(nombredepointsSystèmeArrivée) * zoom)-(pointSCANx(nombredepointsSystèmeArrivée) * zoom + 4, pointSCANy(nombredepointsSystèmeArrivée) * zoom), RGB(0, 255, 0)
'Call AFFICHERVALEURSDESPOINTS
End Sub

Sub AFFICHERPOINTSDUDXFSURPICTURE()
'fonction qui va dessiner les points sur la pictureBOX
i = 1
For i = 1 To nombredepointsdxf
'on dessine les points
PicDEST.PSet (pointDXFx(i) * zoom, pointDXFy(i) * zoom), QBColor(4)
'on dessine les repères verticaux et horizontaux des points
PicDEST.Line (pointDXFx(i) * zoom, pointDXFy(i) * zoom - 4)-(pointDXFx(i) * zoom, pointDXFy(i) * zoom + 4), RGB(0, 0, 255)
PicDEST.Line (pointDXFx(i) * zoom - 4, pointDXFy(i) * zoom)-(pointDXFx(i) * zoom + 4, pointDXFy(i) * zoom), RGB(0, 0, 255)
Next i
'on appelle la fonction qui va afficher les valeurs des points sur la pictureBOX
Call AFFICHERVALEURSDESPOINTS
End Sub

Sub AFFICHERVALEURSDESPOINTS()
'fonction qui va afficher les valeurs des points sur la pictureBOX
PicDEST.ForeColor = vbRed
For i = 1 To nombredepointsdxf
'affichage des textes des coordonnées X'
PicDEST.CurrentX = pointDXFx(i) + 8
PicDEST.CurrentY = pointDXFy(i) - 8
PicDEST.Print "X" & i & "=" & pointDXFx(i)
Next i
'affichage des textes des coordonnées Y'
For i = 1 To nombredepointsdxf
PicDEST.CurrentX = pointDXFx(i) - 8
PicDEST.CurrentY = pointDXFy(i) + 8
PicDEST.Print "Y" & i & "=" & pointDXFy(i)
Next i
End Sub

Private Sub CBLANCERCALCULHELMERT_Click()
'repd contient les points dans les coordonnées du système à adapter
'(j'ouvre le fichier DXF et je charge les points dans repd-> on met en forme la matrice M1)
'repa contient les coordonnées mesurées.
'(je clique les points sur le plan scanné (picturebox) que je mets dans repa-> on met en forme la matrice M2)

Dim repd()
Dim repa()
Dim maxpoint, nbpoint As Double
Dim M1() As Double
Dim M2() As Double
Dim M3() As Double
Dim M4() As Double
Dim M5() As Double
Dim residus() As Double
Dim param(3) As Double
Dim par As Double
Dim moyennequadra As Double

'*****************************************matinit****************************************'
maxpoint = TxtnombredepointsDXF.Text
nbpoint = TxtnombredepointsSCAN.Text
'vérifie les données et initialise
'**********************************************'
ReDim repd(maxpoint - 1, maxpoint - 1)
'on charge repd avec les points du DXF
For i = 0 To maxpoint - 1
repd(i, 0) = pointDXFx(i + 1)
repd(i, 1) = pointDXFy(i + 1)
Next i
'**********************************************'
'maxpoint = UBound(repd) + 1
'nbpoint = UBound(repa) + 1
If maxpoint <> nbpoint Then
MsgBox "Calcul impossible, nombre de points différents dans chaque repère", vbOKOnly
Exit Sub
Else
'**********************************************'
ReDim repa(nbpoint - 1, nbpoint - 1)
'on charge repa avec les points cliqués sur le scan
For i = 0 To maxpoint - 1
repa(i, 0) = pointSCANx(i + 1)
repa(i, 1) = pointSCANy(i + 1)
Next i
'**********************************************'
'on met en forme les matrices
ReDim M1(2 * maxpoint - 1, 3) 'A
ReDim M2(2 * maxpoint - 1) 'K

For i = 0 To maxpoint - 1

    
        M1(2 * i, 0) = repd(i, 0)
        M1(2 * i, 1) = -repd(i, 1)
        M1(2 * i, 2) = 1
        M1(2 * i, 3) = 0
        M2(2 * i) = repa(i, 0)
        M1(2 * i + 1, 1) = repd(i, 0)
        M1(2 * i + 1, 0) = repd(i, 1)
        M1(2 * i + 1, 2) = 0
        M1(2 * i + 1, 3) = 1
        M2(2 * i + 1) = repa(i, 1)
    
Next i

End If
'*********************************transmat***********************************************'

ReDim M3(3, 2 * maxpoint - 1)
'calcul tA

For j = 0 To 3

    For i = 0 To 2 * maxpoint - 1
    M3(j, i) = M1(i, j)
    Next i

Next j

'******************************** multmat()**********************************************'
ReDim M4(3, 3)
ReDim M5(3)

'calcul tAA
For i = 0 To 3
    For j = 0 To 3
    M4(i, j) = 0
        For k = 0 To 2 * maxpoint - 1
        M4(i, j) = M4(i, j) + M3(i, k) * M1(k, j)
        Next k
    Next j
Next i

'calcul de tAK
For i = 0 To 3
M5(i) = 0
    For j = 0 To 2 * maxpoint - 1
    M5(i) = M5(i) + M3(i, j) * M2(j)
    Next j
Next i

'***********************************triangmat***********************************************'

'triangularisation de tAAX=tAK soit M4X=M5
For j = 0 To 2
        
            i = j + 1
            For k = i To 3
                
                    par = M4(k, j) / M4(i - 1, j)
                        
                        For l = j To 3
                        M4(k, l) = M4(k, l) - par * M4(i - 1, l)
                        Next l
                        
                    M5(k) = M5(k) - par * M5(i - 1)
               
                Next k
       
Next j
'****************************************defparam*******************************************'
param(3) = M5(3) / M4(3, 3)
For i = 2 To 0 Step -1
par = 0
    For j = i + 1 To 3
    par = par + M4(i, j) * param(j)
    Next j
param(i) = (M5(i) - par) / M4(i, i)
Next i
'on affiche les paramètres a,b,p,q de la transformation d'HELMERT dans les textes sur la frame frmChoisirPointsSystèmeArrivée
Txta.Text = param(0)
Txtb.Text = param(1)
Txtp.Text = param(2)
Txtq.Text = param(3)
'*****************calculresidus************************************************************'
ReDim residus(2 * maxpoint - 1)

For i = 0 To 2 * maxpoint - 1
    residus(i) = 0
    
    For j = 0 To 3
    residus(i) = residus(i) + M1(i, j) * param(j)
    Next j
Next i

For i = 0 To maxpoint - 1
residus(i * 2) = residus(2 * i) - M2(i * 2)
residus(2 * i + 1) = residus(2 * i + 1) - M2(2 * i + 1)
Next i

'*********************calculmoyquadra******************************************************'
'Dim w0, w1 As Double
'w0 = 0
'w1 = 0
'For i% = 0 To maxpoint - 1
'w0 = w0 + residus(2 * i%) * residus(2 * i%)
'w1 = w1 + residus(2 * i% + 1) * residus(2 * i% + 1)
'Next i%
'w0 = w0 / maxpoint
'w1 = w1 / maxpoint
'moyennequadra = Sqr(wo + w1)

'on recalcule les points transformés
For i = 0 To maxpoint - 1
pointtransformex(i + 1) = param(0) * pointDXFx(i + 1) + param(1) * pointDXFy(i + 1) + param(2)
pointtransformey(i + 1) = -param(1) * pointDXFx(i + 1) + param(0) * pointDXFy(i + 1) + param(3)
'au préalable : tous les textes ou label doivent exister et être d'indice 0 (Txttransformedex(0),TxttransformedeY(0),Lblpointtransforme(0))
'on crée le nombre de texte et de label selon le nombre de points transformés
Dim iNewItem As Integer
    'Trouver l'index à créer
    iNewItem = Txttransformedex.UBound + 1
    'Créer le nouveau contôle Txttransformedex et le positionner
    Load Txttransformedex(iNewItem)
    Txttransformedex(iNewItem).Top = Txttransformedex(iNewItem - 1).Top + Txttransformedex(iNewItem - 1).Height
    Txttransformedex(iNewItem).Left = Txttransformedex(iNewItem - 1).Left
    Txttransformedex(iNewItem).Visible = True
    Txttransformedex(iNewItem).Text = pointtransformex(iNewItem)
Dim jNewItem As Integer
    'Trouver l'index à créer
    jNewItem = TxttransformedeY.UBound + 1
    'Créer le nouveau contôle Txttransformedey et le positionner
    Load TxttransformedeY(jNewItem)
    TxttransformedeY(jNewItem).Top = TxttransformedeY(jNewItem - 1).Top + TxttransformedeY(jNewItem - 1).Height
    TxttransformedeY(jNewItem).Left = TxttransformedeY(jNewItem - 1).Left
    TxttransformedeY(jNewItem).Visible = True
    TxttransformedeY(jNewItem).Text = pointtransformey(jNewItem)
Dim kNewItem As Integer
    'Trouver l'index à créer
    kNewItem = Lblpointtransforme.UBound + 1
    'Créer le nouveau contôle Lblpointtransforme et le positionner
    Load Lblpointtransforme(kNewItem)
    Lblpointtransforme(kNewItem).Top = Lblpointtransforme(kNewItem - 1).Top + Lblpointtransforme(kNewItem - 1).Height
    Lblpointtransforme(kNewItem).Left = Lblpointtransforme(kNewItem - 1).Left
    Lblpointtransforme(kNewItem).Caption = "Point" & kNewItem & ":"
    Lblpointtransforme(kNewItem).Visible = True
Next i
'on efface les points dessinés au préalable
PicDEST.Cls
i = 1
For i = 1 To maxpoint
'on dessine les points
PicDEST.PSet (pointtransformex(i) * zoom, pointtransformey(i) * zoom), QBColor(4)
'on dessine les repères verticaux et horizontaux des points
PicDEST.Line (pointtransformex(i) * zoom, pointtransformey(i) * zoom - 4)-(pointtransformex(i) * zoom, pointtransformey(i) * zoom + 4), RGB(0, 0, 255)
PicDEST.Line (pointtransformex(i) * zoom - 4, pointtransformey(i) * zoom)-(pointtransformex(i) * zoom + 4, pointtransformey(i) * zoom), RGB(0, 0, 255)
Next i
PicDEST.ForeColor = vbRed
For i = 1 To maxpoint
'affichage des textes des positions X et Y avec la valeur des points du dxf'
PicDEST.CurrentX = pointtransformex(i) + 8
PicDEST.CurrentY = pointtransformey(i) - 8
PicDEST.Print "X" & i & "=" & pointDXFx(i)
Next i
For i = 1 To maxpoint
PicDEST.CurrentX = pointtransformex(i) - 8
PicDEST.CurrentY = pointtransformey(i) + 8
PicDEST.Print "Y" & i & "=" & pointDXFy(i)
Next i
MsgBox "fin de la transformation d'helmert", vbOKOnly
ChoisirPointsSystèmeArrivée = 0
'frmChoisirPointsSystèmeArrivée.Visible = False
End Sub

Private Sub Cbraz_Click()
PicDEST.Cls
Dim maxpoint, nbpoint As Double
Dim iNewItem As Integer
maxpoint = TxtnombredepointsDXF.Text
For i = 1 To maxpoint
Unload Txtscanx(i)
Unload Txtscany(i)
Unload Txttransformedex(i)
Unload TxttransformedeY(i)
Next i
nombredepointsSystèmeArrivée = 0
TxtnombredepointsSCAN = 0
reponse = MsgBox("Veuillez Choisir les Points du Système d'Arrivée en les Cliquant consécutivement sur le Plan Scanné", vbYesNo)
If reponse = vbYes Then
nombredepointsSystèmeArrivée = 0
TxtnombredepointsSCAN.Text = 0
ChoisirPointsSystèmeArrivée = 1
End If
End Sub

Private Sub VScroll1_Change(index As Integer)
Picinterne(index).Top = -VScroll1(index).Value
End Sub

Private Sub VScroll1_Scroll(index As Integer)
Picinterne(index).Top = -VScroll1(index).Value
End Sub

Private Sub PicDEST_DragDrop(Source As Control, X As Single, Y As Single)
'permet de déplacer la frame frmChoisirPointsSystèmeArrivée sur picDEST
If TypeOf Source Is Frame Then
Source.Move X, Y
End If
End Sub