1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
|
Option Explicit
#Const ccCALCRANGES = False
Private Type tXY
dx As Double
dy As Double
End Type
Private gdPI As Double
Private gWidth As Long
Private gHeight As Long
Private dZoomX As Double, dZoomY As Double, dRapportXSurY As Double
Private dDecalageX As Double, dDecalageY As Double
Private clGdip As ClGdiPlus
Private Sub Form_Load()
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim asPoints() As String
Dim i As Long, lColor As Long, lEtendue As Long
Dim dMinX As Double, dMaxX As Double, dMinY As Double
Dim tPoint1 As tXY, tPoint2 As tXY
' Cration de l'image vierge
Set clGdip = New ClGdiPlus
gWidth = clGdip.PointsToPixelsX(Me.ImageMiller.Width)
gHeight = clGdip.PointsToPixelsY(Me.ImageMiller.Height)
clGdip.CreateBitmap gWidth, gHeight
clGdip.FillColor vbWhite
'Calcul de PI
gdPI = 4 * Atn(1)
'Ouverture de la table
Set oDb = CurrentDb
Set oRs = oDb.OpenRecordset("tmppays", dbOpenTable)
'1ère boucle pour déterminer les valeurs extrèmes de la projection
#If ccCALCRANGES Then
dMinX = 2 ^ 30
dMinY = 2 ^ 30
While Not oRs.EOF
asPoints = Split(oRs!contours, ",")
For i = 0 To UBound(asPoints()) - 1 Step 2
tPoint1 = GetXYFromProjMiller(Val(asPoints(i)), Val(asPoints(i + 1)))
If tPoint1.dx < dMinX Then dMinX = tPoint1.dx
If tPoint1.dx > dMaxX Then dMaxX = tPoint1.dx
If tPoint1.dy < dMinY Then dMinY = tPoint1.dy
Next i
oRs.MoveNext
Wend
Debug.Print "dMinX:" & dMinX, "dMaxX:" & dMaxX, "dMinY:" & dMinY
#Else
dMinX = -3.1415958493831
dMaxX = 3.14159265358979
dMinY = -1.98474497464755
#End If
'Paramètres du dessin
'Me.DrawWidth = 1
lColor = vbRed
'Paramètres de centrage sur l'image
dRapportXSurY = 1
dZoomX = (gWidth - 20) / (dMaxX - dMinX) 'Me.ImageMiller.ImageWidth / (dMaxX - dMinX)
dDecalageX = -(dMinX * dZoomX) + 10
dZoomY = dZoomX * dRapportXSurY
dDecalageY = -(dMinY * dZoomY) + 10
'Dessine le contour des pays selon la projection de Miller
oRs.MoveFirst
While Not oRs.EOF
asPoints = Split(oRs!contours, ",")
' Calcul la position des points en pixels
For i = 0 To UBound(asPoints()) - 1 Step 2
tPoint1 = GetXYFromProjMiller(Val(asPoints(i)), Val(asPoints(i + 1)))
asPoints(i) = (dZoomX * tPoint1.dx) + dDecalageX
asPoints(i + 1) = (dZoomY * tPoint1.dy) + dDecalageY
Next i
' Ajoute un point si nécessaire pour fermer le polygone
If asPoints(UBound(asPoints()) - 1) <> asPoints(0) Or asPoints(UBound(asPoints())) <> asPoints(1) Then
ReDim Preserve asPoints(UBound(asPoints()) + 2)
asPoints(i) = asPoints(0)
asPoints(i + 1) = asPoints(1)
End If
' Dessine le polygone
clGdip.DrawPolygon asPoints, , lColor, 1
' Crée une région
clGdip.CreateRegionPolygon oRs!Name, asPoints
oRs.MoveNext
Wend
Set oRs = Nothing
Set oDb = Nothing
' Dessine un cercle à l'emplacement de la ville d'orléans
tPoint1 = GetXYFromProjMiller(1.9043, 47.90211) ' Orleans
tPoint1.dx = (dZoomX * tPoint1.dx) + dDecalageX
tPoint1.dy = (dZoomY * tPoint1.dy) + dDecalageY
clGdip.DrawEllipse tPoint1.dx, tPoint1.dy, 5, 5, 1, vbRed, vbGreen, 1
' Calcule la taille nécessaire à l'affichage du nom de la ville
clGdip.DrawText "Orléans" & vbNullChar, CLng(15), "Arial", lLeft, ltop, lRight, lBottom, , , , , , , , , , , , True
' Affiche le nom de la ville
clGdip.DrawText "Orléans", 15, "Arial", CLng(tPoint1.dx), CLng(tPoint1.dy), CLng(tPoint1.dx) + (lRight - lLeft), CLng(tPoint1.dy) + (lBottom - ltop), , , vbBlue, , vbYellow, 100, , True
' Conserve l'image de base en mémoire
clGdip.KeepImage
' Dessine l'image
Me.ImageMiller.PictureData = clGdip.GdiPlusToPictureData
End Sub
Private Sub ImageMiller_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lRegion As String
Dim tPoint As tXY
Dim lCpt As Long
lRegion = clGdip.GetMouseRegion(clGdip.CtrlToImgX(X, Me.ImageMiller), clGdip.CtrlToImgY(Y, Me.ImageMiller))
clGdip.ResetImage
clGdip.FrameRegion lRegion, vbRed, , , 50
Me.ImageMiller.PictureData = clGdip.GdiPlusToPictureData
' Affiche le pays survolé
Me.TxtRegion.Value = lRegion
' Calcul la longitude et latitude sous la souris
tPoint.dx = (clGdip.CtrlToImgX(X, Me.ImageMiller) - dDecalageX) / dZoomX
tPoint.dy = (clGdip.CtrlToImgY(Y, Me.ImageMiller) - dDecalageY) / dZoomY
tPoint = GetLonLat(tPoint.dx, tPoint.dy)
' Affiche la longitude et la latitude
Me.TxtLon.Value = tPoint.dx
Me.TxtLat.Value = tPoint.dy
End Sub
Private Function GetXYFromProjMiller(ByVal dLon As Double, ByVal dLat As Double) As tXY
GetXYFromProjMiller.dx = dLon * gdPI / 180
GetXYFromProjMiller.dy = -1.25 * Log(Tan(gdPI * (0.25 + dLat / 450)))
End Function
Private Function GetLonLat(pX As Double, pY As Double) As tXY
GetLonLat.dx = pX / gdPI * 180
GetLonLat.dy = ((Atn(Exp(pY / -1.25)) / gdPI) - 0.25) * 450
End Function |
Partager