Calcul de distance dynamique et remplir une table

Bonjour,
voici le code que j'ai écrit dans le VBA Access et je sais où est l'erreur car il me parrait qu'il est complet
PS: je suis pas un expert en Access ou VBA

le code :

Option Compare Database
Function distance2()

On Error GoTo Error_Handler

Dim X1 As Variant

Dim Y1 As Variant

Dim X2 As Variant

Dim Y2 As Variant

Dim Lon_WGS80 As Variant

Dim Lat_WGS80 As Variant

Dim D As Long
Dim source() As Variant
Dim target() As Variant
Dim rsFunctions As Recordset

' test :

sQryName = "Requête2"
sSQL = "SELECT [Requête1].Source, [Requête1].Target, * FROM Requête1 INNER JOIN CE_coord1 ON [Requête1].Target=CE_coord1.Cell;"

Set qdf = CurrentDb.QueryDefs(sQryName)
qdf.SQL = sSQL 'Redefine the Query's SQL

Set rsFunctions = CurrentDb.OpenRecordset("select * from Requête2")

While Not rsFunctions.EOF
On Error Resume Next
ReDim Preserve target(i)
target(i) = rsFunctions("Target")

ReDim Preserve X2(i)
X2(i) = rsFunctions("Lon_WGS80")
ReDim Preserve Y2(i)
Y2(i) = rsFunctions("Lat_WGS80")

i = i + 1
On Error GoTo 0
rsFunctions.MoveNext
Wend

sQryName = "Requête3"
sSQL = "SELECT [Requête1].Source, [Requête1].Target, * FROM Requête1 INNER JOIN CE_coord1 ON [Requête1].Source =CE_coord1.Cell;"

Set qdf = CurrentDb.QueryDefs(sQryName)
qdf.SQL = sSQL 'Redefine the Query's SQL

Set rsFunctions = CurrentDb.OpenRecordset("select * from Requête3")
While Not rsFunctions.EOF

On Error Resume Next

ReDim Preserve source(i)
source(i) = rsFunctions("Source")

ReDim Preserve X(i)
X1(i) = rsFunctions("Lon_WGS80")
ReDim Preserve Y1(i)
Y1(i) = rsFunctions("Lat_WGS80")

i = i + 1
On Error GoTo 0
rsFunctions.MoveNext

D = 6378.137 * Atn(Sqr((1 - (Sin(Y1 / 57.29577951) * Sin(Y2 / 57.29577951) + Cos(Y1 / 57.29577951) * Cos(X1 / 57.29577951) * Cos(X1 / 57.29577951 - X2 / 57.29577951)) ^ 2)) / (Sin(Y1 / 57.29577951) * Sin(X1 / 57.29577951) + Cos(Y1 / 57.29577951) * Cos(X1 / 57.29577951) * Cos(X1 / 57.29577951 - X2 / 57.29577951)))

ReDim Preserve source(i)
CurrentDb.Execute "INSERT INTO Table2 (src,tgt,dis) VALUES ('" & rsFunctions("Source") & "', '" & rsFunctions("Target") & "','" & ("D") & "');"

source(i) = rsFunctions("Source")
i = i + 1
On Error GoTo 0
' rsFunctions.MoveNext
Wend

Error_Handler_Exit:
On Error Resume Next
Set qdf = Nothing
Exit Function
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: RedefQry" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function

2 réponses

  1. Modérateur
    Salut,

    et c'est quoi l'erreur, parce que depuis chez moi, je ne vois pas...
    0
    1. le problème c que la Table2 n'est pas rempli par les éléments selectionnés , et ça me rend dingue , de chez moi aussi je ne vois pas pk
      0
      1. Modérateur
        Moi, je créerais la chaine contenant la chaine à passer en paramètre du runsql et je ferais un msgox avant, comme ça, on peut se rendre compte si la syntaxe est correcte.
        0
      2. et comment faire ça ?
        0
      3. Modérateur
        Tu crées une variable de type chaine au début de ta procédure.
        Tu la remplis ensuite, tu l'affcihes avant de la passer à l'exécution, comme ça, tu vois si tout est bien formaté (guillemets, virgules et autres).

        Dim StrSql
        ...
        ...
        StrSql = "INSERT INTO Table2 (src,tgt,dis) VALUES ('" & rsFunctions("Source") & "', '" & rsFunctions("Target") & "','" & ("D") & "');"
        MsgBox StrSql
        CurrentDb.execute (StrSql)
        0
      4. Merci beaucoup , mais j'ai tjrs bcp de question
        0
      5. Modérateur
        ???
        0