Calcul de distance dynamique et remplir une table
Charle159
Messages postés
4
Date d'inscription
Statut
Membre
Dernière intervention
-
blux Messages postés 27147 Date d'inscription Statut Modérateur Dernière intervention -
blux Messages postés 27147 Date d'inscription Statut Modérateur Dernière intervention -
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
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
A voir également:
- Calcul de distance dynamique et remplir une table
- Table ascii - Guide
- Table des matières word - Guide
- Allumer pc à distance - Guide
- Tableau croisé dynamique - Guide
- Calcul moyenne excel - Guide
2 réponses
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
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).
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)