Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
des pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
des pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
des pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" a écrit dans le message de
news:Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lalecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créerdes pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" <patrice.henrio@laposte.net> a écrit dans le message de
news:OP6UhTT1EHA.3408@tk2msftngp13.phx.gbl...
Je souhaite lancer une discussion sur les API graphiques. En effet malgré
la
lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créer
des pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" a écrit dans le message de
news:Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lalecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créerdes pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les
API de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une
certaine logique, ces classes étant interdépendantes pour constituer un
modele objet global de gestion graphique à partir de controle standards
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer
de formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils
graphiques, puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte,
enfin n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais
elle ne sont là que temporairement, de fait j'utilise plutôt des objet
Ligne, TEXT,image,polygone de ma création , qui viennent se dessiner
sur un metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et
fonction inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire
des impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal
hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String,
ByVal nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As
Rect, ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As
Long, ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long,
lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long,
lppt As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long,
lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long,
ByVal nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As
Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long,
ByVal nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As
Long, lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long,
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture
'box pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont
'à sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport
' à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :
> Bnjr Patrice,
>
> Puis-je te suggérer
> d'aller voir un outil sympa, http://www.progotop.com/popapi/
> avec un forum avec quelques passionnés de ce genre de pb.
> http://forum.progotop.com/index.php
>
> C'est pas pour décourager de VB sur MPFV,
> mais il y a qq. (pas bcp) "chébrans" exclusifs....
> ou aussi VBFrance à partir des sources exemples d'usages
> Pour info.
> Yann
>
> "Patrice Henrio" a écrit dans le message de
> news:
>
>>Je souhaite lancer une discussion sur les API graphiques. En effet
>
> la
>
>>lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on
>>faire avec ces API.
>>
>>Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
>
> créer
>
>>des pinceaux avec des motifs personnels ...
>>En particulier j'utilise actuellement :
>>
>>Private Declare Function CreateSolidBrush Lib "gdi32" _
>> (ByVal crColor As Long) As Long
>>Private Declare Function PolyPolygon Lib "gdi32.dll" _
>> (ByVal hdc As Long, _
>> lpPoint As PointAPI, _
>> lpPolyCounts As Long, _
>> ByVal nCount As Long) As Long
>>Private Declare Function SelectObject Lib "gdi32" _
>> (ByVal hdc As Long, _
>> ByVal hObject As Long) As Long
>>Private Declare Function DeleteObject Lib "gdi32" _
>> (ByVal hObject As Long) As Long
>>Private Declare Function CreatePolygonRgn Lib "gdi32" _
>> (lpPoint As PointAPI, _
>> ByVal nCount As Long, _
>> ByVal nPolyFillMode As Long)
>>Long
>>Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
>> (lpPoint As PointAPI, _
>> lpPolyCounts As Long, _
>> ByVal nCount As Long, _
>> ByVal nPolyFillMode As
>>As Long
>>Private Declare Function PtInRegion Lib "gdi32" _
>> (ByVal hRgn As Long, _
>> ByVal X As Long, _
>> ByVal Y As Long) As Long
>>Private Declare Function FillRgn Lib "gdi32" _
>> (ByVal hdc As Long, _
>> ByVal hRgn As Long, _
>> ByVal hBrush As Long) As Long
>>Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
>> (pDst As Any, _
>> pSrc As Any, _
>> ByVal ByteLen As Long)
>>Private Declare Function CreateEllipticRgn Lib "gdi32" _
>> (ByVal X1 As Long, _
>> ByVal Y1 As Long, _
>> ByVal X2 As Long, _
>> ByVal Y2 As Long) As Long
>>Private Declare Function RegCloseKey Lib "advapi32.dll" _
>> (ByVal hKey As Long) As Long
>>Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
>>"RegCreateKeyA" _
>> (ByVal hKey As Long, _
>> ByVal lpSubKey As String, _
>> phkResult As Long) As Long
>>Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
>>"RegSetValueExA" _
>> (ByVal hKey As Long, _
>> ByVal lpValueName As String, _
>> ByVal Reserved As Long, _
>> ByVal dwType As Long, _
>> lpData As Any, _
>> ByVal cbData As Long) As Long
>>Private Declare Function PolyPolyline Lib "gdi32.dll" _
>> (ByVal hdc As Long, _
>> lppt As PointAPI, _
>> lpdwPolyPoints As Long, _
>> ByVal cCount As Long) As Long
>>Private Const ALTERNATE = 1
>>
>>
>
>
>
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les
API de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une
certaine logique, ces classes étant interdépendantes pour constituer un
modele objet global de gestion graphique à partir de controle standards
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer
de formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils
graphiques, puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte,
enfin n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais
elle ne sont là que temporairement, de fait j'utilise plutôt des objet
Ligne, TEXT,image,polygone de ma création , qui viennent se dessiner
sur un metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et
fonction inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire
des impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal
hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String,
ByVal nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As
Rect, ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As
Long, ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long,
lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long,
lppt As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long,
lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long,
ByVal nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As
Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long,
ByVal nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As
Long, lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long,
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture
'box pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont
'à sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport
' à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :
> Bnjr Patrice,
>
> Puis-je te suggérer
> d'aller voir un outil sympa, http://www.progotop.com/popapi/
> avec un forum avec quelques passionnés de ce genre de pb.
> http://forum.progotop.com/index.php
>
> C'est pas pour décourager de VB sur MPFV,
> mais il y a qq. (pas bcp) "chébrans" exclusifs....
> ou aussi VBFrance à partir des sources exemples d'usages
> Pour info.
> Yann
>
> "Patrice Henrio" <patrice.henrio@laposte.net> a écrit dans le message de
> news:OP6UhTT1EHA.3408@tk2msftngp13.phx.gbl...
>
>>Je souhaite lancer une discussion sur les API graphiques. En effet
>
> la
>
>>lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on
>>faire avec ces API.
>>
>>Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
>
> créer
>
>>des pinceaux avec des motifs personnels ...
>>En particulier j'utilise actuellement :
>>
>>Private Declare Function CreateSolidBrush Lib "gdi32" _
>> (ByVal crColor As Long) As Long
>>Private Declare Function PolyPolygon Lib "gdi32.dll" _
>> (ByVal hdc As Long, _
>> lpPoint As PointAPI, _
>> lpPolyCounts As Long, _
>> ByVal nCount As Long) As Long
>>Private Declare Function SelectObject Lib "gdi32" _
>> (ByVal hdc As Long, _
>> ByVal hObject As Long) As Long
>>Private Declare Function DeleteObject Lib "gdi32" _
>> (ByVal hObject As Long) As Long
>>Private Declare Function CreatePolygonRgn Lib "gdi32" _
>> (lpPoint As PointAPI, _
>> ByVal nCount As Long, _
>> ByVal nPolyFillMode As Long)
>>Long
>>Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
>> (lpPoint As PointAPI, _
>> lpPolyCounts As Long, _
>> ByVal nCount As Long, _
>> ByVal nPolyFillMode As
>>As Long
>>Private Declare Function PtInRegion Lib "gdi32" _
>> (ByVal hRgn As Long, _
>> ByVal X As Long, _
>> ByVal Y As Long) As Long
>>Private Declare Function FillRgn Lib "gdi32" _
>> (ByVal hdc As Long, _
>> ByVal hRgn As Long, _
>> ByVal hBrush As Long) As Long
>>Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
>> (pDst As Any, _
>> pSrc As Any, _
>> ByVal ByteLen As Long)
>>Private Declare Function CreateEllipticRgn Lib "gdi32" _
>> (ByVal X1 As Long, _
>> ByVal Y1 As Long, _
>> ByVal X2 As Long, _
>> ByVal Y2 As Long) As Long
>>Private Declare Function RegCloseKey Lib "advapi32.dll" _
>> (ByVal hKey As Long) As Long
>>Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
>>"RegCreateKeyA" _
>> (ByVal hKey As Long, _
>> ByVal lpSubKey As String, _
>> phkResult As Long) As Long
>>Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
>>"RegSetValueExA" _
>> (ByVal hKey As Long, _
>> ByVal lpValueName As String, _
>> ByVal Reserved As Long, _
>> ByVal dwType As Long, _
>> lpData As Any, _
>> ByVal cbData As Long) As Long
>>Private Declare Function PolyPolyline Lib "gdi32.dll" _
>> (ByVal hdc As Long, _
>> lppt As PointAPI, _
>> lpdwPolyPoints As Long, _
>> ByVal cCount As Long) As Long
>>Private Const ALTERNATE = 1
>>
>>
>
>
>
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les
API de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une
certaine logique, ces classes étant interdépendantes pour constituer un
modele objet global de gestion graphique à partir de controle standards
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer
de formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils
graphiques, puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte,
enfin n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais
elle ne sont là que temporairement, de fait j'utilise plutôt des objet
Ligne, TEXT,image,polygone de ma création , qui viennent se dessiner
sur un metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et
fonction inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire
des impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal
hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String,
ByVal nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As
Rect, ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As
Long, ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long,
lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long,
lppt As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long,
lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long,
ByVal nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As
Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long,
ByVal nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As
Long, lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long,
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture
'box pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont
'à sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport
' à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :
> Bnjr Patrice,
>
> Puis-je te suggérer
> d'aller voir un outil sympa, http://www.progotop.com/popapi/
> avec un forum avec quelques passionnés de ce genre de pb.
> http://forum.progotop.com/index.php
>
> C'est pas pour décourager de VB sur MPFV,
> mais il y a qq. (pas bcp) "chébrans" exclusifs....
> ou aussi VBFrance à partir des sources exemples d'usages
> Pour info.
> Yann
>
> "Patrice Henrio" a écrit dans le message de
> news:
>
>>Je souhaite lancer une discussion sur les API graphiques. En effet
>
> la
>
>>lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on
>>faire avec ces API.
>>
>>Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
>
> créer
>
>>des pinceaux avec des motifs personnels ...
>>En particulier j'utilise actuellement :
>>
>>Private Declare Function CreateSolidBrush Lib "gdi32" _
>> (ByVal crColor As Long) As Long
>>Private Declare Function PolyPolygon Lib "gdi32.dll" _
>> (ByVal hdc As Long, _
>> lpPoint As PointAPI, _
>> lpPolyCounts As Long, _
>> ByVal nCount As Long) As Long
>>Private Declare Function SelectObject Lib "gdi32" _
>> (ByVal hdc As Long, _
>> ByVal hObject As Long) As Long
>>Private Declare Function DeleteObject Lib "gdi32" _
>> (ByVal hObject As Long) As Long
>>Private Declare Function CreatePolygonRgn Lib "gdi32" _
>> (lpPoint As PointAPI, _
>> ByVal nCount As Long, _
>> ByVal nPolyFillMode As Long)
>>Long
>>Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
>> (lpPoint As PointAPI, _
>> lpPolyCounts As Long, _
>> ByVal nCount As Long, _
>> ByVal nPolyFillMode As
>>As Long
>>Private Declare Function PtInRegion Lib "gdi32" _
>> (ByVal hRgn As Long, _
>> ByVal X As Long, _
>> ByVal Y As Long) As Long
>>Private Declare Function FillRgn Lib "gdi32" _
>> (ByVal hdc As Long, _
>> ByVal hRgn As Long, _
>> ByVal hBrush As Long) As Long
>>Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
>> (pDst As Any, _
>> pSrc As Any, _
>> ByVal ByteLen As Long)
>>Private Declare Function CreateEllipticRgn Lib "gdi32" _
>> (ByVal X1 As Long, _
>> ByVal Y1 As Long, _
>> ByVal X2 As Long, _
>> ByVal Y2 As Long) As Long
>>Private Declare Function RegCloseKey Lib "advapi32.dll" _
>> (ByVal hKey As Long) As Long
>>Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
>>"RegCreateKeyA" _
>> (ByVal hKey As Long, _
>> ByVal lpSubKey As String, _
>> phkResult As Long) As Long
>>Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
>>"RegSetValueExA" _
>> (ByVal hKey As Long, _
>> ByVal lpValueName As String, _
>> ByVal Reserved As Long, _
>> ByVal dwType As Long, _
>> lpData As Any, _
>> ByVal cbData As Long) As Long
>>Private Declare Function PolyPolyline Lib "gdi32.dll" _
>> (ByVal hdc As Long, _
>> lppt As PointAPI, _
>> lpdwPolyPoints As Long, _
>> ByVal cCount As Long) As Long
>>Private Const ALTERNATE = 1
>>
>>
>
>
>
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les API
de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une certaine
logique, ces classes étant interdépendantes pour constituer un modele
objet global de gestion graphique à partir de controle standards VB.
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer de
formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils graphiques,
puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte, enfin
n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais elle
ne sont là que temporairement, de fait j'utilise plutôt des objet Ligne,
TEXT,image,polygone de ma création , qui viennent se dessiner sur un
metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et fonction
inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire des
impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture 'box
pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont 'à
sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
'****************************************************************************
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport '
à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" a écrit dans le message de
news:Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lalecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créerdes pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As
Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les API
de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une certaine
logique, ces classes étant interdépendantes pour constituer un modele
objet global de gestion graphique à partir de controle standards VB.
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer de
formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils graphiques,
puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte, enfin
n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais elle
ne sont là que temporairement, de fait j'utilise plutôt des objet Ligne,
TEXT,image,polygone de ma création , qui viennent se dessiner sur un
metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et fonction
inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire des
impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture 'box
pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont 'à
sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
'****************************************************************************
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport '
à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :
Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" <patrice.henrio@laposte.net> a écrit dans le message de
news:OP6UhTT1EHA.3408@tk2msftngp13.phx.gbl...
Je souhaite lancer une discussion sur les API graphiques. En effet malgré
la
lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créer
des pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As
Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les API
de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une certaine
logique, ces classes étant interdépendantes pour constituer un modele
objet global de gestion graphique à partir de controle standards VB.
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer de
formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils graphiques,
puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte, enfin
n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais elle
ne sont là que temporairement, de fait j'utilise plutôt des objet Ligne,
TEXT,image,polygone de ma création , qui viennent se dessiner sur un
metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et fonction
inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire des
impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture 'box
pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont 'à
sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
'****************************************************************************
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport '
à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" a écrit dans le message de
news:Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lalecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créerdes pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As
Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
4°/ une vraie logique de classes pour des développements,
mais en VB : mince alors, je ne croyais cela possible qu'en C++
(ou alors tu es déjà en VB.Net)
Effectivement, on ne peut pas rentrer la-dedans comme dans un moulin,
mais meme la rédaction d'un graphique VB par MSChart ou Excel
c'est pas de la tarte.....
4°/ une vraie logique de classes pour des développements,
mais en VB : mince alors, je ne croyais cela possible qu'en C++
(ou alors tu es déjà en VB.Net)
Effectivement, on ne peut pas rentrer la-dedans comme dans un moulin,
mais meme la rédaction d'un graphique VB par MSChart ou Excel
c'est pas de la tarte.....
4°/ une vraie logique de classes pour des développements,
mais en VB : mince alors, je ne croyais cela possible qu'en C++
(ou alors tu es déjà en VB.Net)
Effectivement, on ne peut pas rentrer la-dedans comme dans un moulin,
mais meme la rédaction d'un graphique VB par MSChart ou Excel
c'est pas de la tarte.....
Bon je vais m'ateler à tout ce travail.
Le sproblèmes de coordonnées ne me posent pas de réels soucis (en tout cas
la partie calcul) car je suis agrégé de maths au départ (et même passionné
de maths).
Dons pour ma part j'utilise un fichier de points en coordonnées terrestres
(longitude de -180 à -180 et latitude de -90 à +90, en degré décimaux).
Ensuite je définis un point central sur la sphère qui sera le point de
tangence d'un plan de projection et de la sphère. En effet je limite l'image
à un carré de 20° au Nord, Sud, Est et Ouest, ce qui me permet de n'avoir
qu'une déformation minime lors de la projection sur le plan. Bien entendu
tout ce qui concerne le relief n'est pas pris en compte.
Je définis des régions et des lignes sur la terre par leurs coordonnées et
les dessine par CreatePolyPolygonRgn, j'utilise toutes les fonctions
nécessaires pour colorier l'intérieur et définir si un point est à
l'intérieur d'une région.
Tu peux voir ce que cela donne en téléchargeant le programme et sa mise à
jour (il faut les deux) à l'adresse
http://scraper.chez.tiscali.fr//index1.htm?histoire.htm
Ensuite je peux te faire parvenir les sources pour ce qui peut t'intéresser
ou surtout que tu comprenne mieux le sproblèmes auxquels je suis confronté.
Les questions en suspens sont donc :
augmenter le nombre de couleurs utilisables et miux comprendre color
colorier une région en bleu et rouge (hâchure) par exemple, ou encore avec
des pointillés.
Je viens de terminer l'écriture du nom du fleuve en écriture cursive qui
suit le parcours du fleuve, mais ce n'est pas transposable pour l'instant
car je considère à l'heure actuelle que ce nom est projeté sur la terre,
traduit donc en coordonnées terrestres (tout cela dans une feuille de
calcul excel) puis stocké dans un fichier binaire.
Lors de l'exécution, le programme remplit un tableau à l'aide du fichier
(une seule lecture avec len), ce tableau est traduit à chaque changement du
point central en coordonnées d'écran et permet ensuite de dessiner avec
polypolyline, le nom du fleuve étant considéré comme faisant partie du
fleuve.
Je te transmets ma procédure DessineFleuves
Public Sub DessineFleuves()
Dim NbPoints As Long, NbLignes As Long, NbPointsParLignes() As Long, Pts()
As PointAPI, _
Index As Integer, I As Integer
NbPoints = 0
'c'est pour l'isntant en phase de test donc le tableau NbPointsParLigne est
rempli à la main
NbLignes = 18
ReDim NbPointsParLignes(1 To NbLignes)
NbPointsParLignes(1) = 198 'UBound(Fleuves)
NbPointsParLignes(2) = 34
NbPointsParLignes(3) = 7
NbPointsParLignes(4) = 113
NbPointsParLignes(5) = 6
NbPointsParLignes(6) = 17
NbPointsParLignes(7) = 7
NbPointsParLignes(8) = 9
NbPointsParLignes(9) = 16
NbPointsParLignes(10) = 29
NbPointsParLignes(11) = 16
NbPointsParLignes(12) = 24
NbPointsParLignes(13) = 27
NbPointsParLignes(14) = 7
NbPointsParLignes(15) = 8
NbPointsParLignes(16) = 7
NbPointsParLignes(17) = 2
NbPointsParLignes(18) = 38
ReDim Preserve Pts(1 To UBound(Fleuves))
For I = 1 To UBound(Fleuves)
Pts(I) = Projection(Fleuves(I))
Next I
DessinFleuves Pts, NbPointsParLignes
Erase NbPointsParLignes, Pts
End Sub
Public Sub DessinFleuves(ByRef Points() As PointAPI, _
ByRef NbPoints() As Long)
'dessine les fleuves
Dim RetVal As Long
FormeHistoire.Carte.ForeColor = vbBlack
PolyPolyline FormeHistoire.Carte.hdc, Points(1), NbPoints(1), 18
End Sub
Si cela se trouve, il y a beaucoup plus simple.
En tout cas merci de ta réponse et de ta proposition de collaboration.
"christophe-pasde<> @wanadoo.fr>" <"christophe-pasde<> a écrit dans le
message de news: 41a9e3da$0$30448$Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les API
de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une certaine
logique, ces classes étant interdépendantes pour constituer un modele
objet global de gestion graphique à partir de controle standards VB.
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer de
formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils graphiques,
puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte, enfin
n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais elle
ne sont là que temporairement, de fait j'utilise plutôt des objet Ligne,
TEXT,image,polygone de ma création , qui viennent se dessiner sur un
metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et fonction
inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire des
impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture 'box
pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont 'à
sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
'****************************************************************************
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport '
à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" a écrit dans le message de
news:Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lalecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créerdes pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As
Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bon je vais m'ateler à tout ce travail.
Le sproblèmes de coordonnées ne me posent pas de réels soucis (en tout cas
la partie calcul) car je suis agrégé de maths au départ (et même passionné
de maths).
Dons pour ma part j'utilise un fichier de points en coordonnées terrestres
(longitude de -180 à -180 et latitude de -90 à +90, en degré décimaux).
Ensuite je définis un point central sur la sphère qui sera le point de
tangence d'un plan de projection et de la sphère. En effet je limite l'image
à un carré de 20° au Nord, Sud, Est et Ouest, ce qui me permet de n'avoir
qu'une déformation minime lors de la projection sur le plan. Bien entendu
tout ce qui concerne le relief n'est pas pris en compte.
Je définis des régions et des lignes sur la terre par leurs coordonnées et
les dessine par CreatePolyPolygonRgn, j'utilise toutes les fonctions
nécessaires pour colorier l'intérieur et définir si un point est à
l'intérieur d'une région.
Tu peux voir ce que cela donne en téléchargeant le programme et sa mise à
jour (il faut les deux) à l'adresse
http://scraper.chez.tiscali.fr//index1.htm?histoire.htm
Ensuite je peux te faire parvenir les sources pour ce qui peut t'intéresser
ou surtout que tu comprenne mieux le sproblèmes auxquels je suis confronté.
Les questions en suspens sont donc :
augmenter le nombre de couleurs utilisables et miux comprendre color
colorier une région en bleu et rouge (hâchure) par exemple, ou encore avec
des pointillés.
Je viens de terminer l'écriture du nom du fleuve en écriture cursive qui
suit le parcours du fleuve, mais ce n'est pas transposable pour l'instant
car je considère à l'heure actuelle que ce nom est projeté sur la terre,
traduit donc en coordonnées terrestres (tout cela dans une feuille de
calcul excel) puis stocké dans un fichier binaire.
Lors de l'exécution, le programme remplit un tableau à l'aide du fichier
(une seule lecture avec len), ce tableau est traduit à chaque changement du
point central en coordonnées d'écran et permet ensuite de dessiner avec
polypolyline, le nom du fleuve étant considéré comme faisant partie du
fleuve.
Je te transmets ma procédure DessineFleuves
Public Sub DessineFleuves()
Dim NbPoints As Long, NbLignes As Long, NbPointsParLignes() As Long, Pts()
As PointAPI, _
Index As Integer, I As Integer
NbPoints = 0
'c'est pour l'isntant en phase de test donc le tableau NbPointsParLigne est
rempli à la main
NbLignes = 18
ReDim NbPointsParLignes(1 To NbLignes)
NbPointsParLignes(1) = 198 'UBound(Fleuves)
NbPointsParLignes(2) = 34
NbPointsParLignes(3) = 7
NbPointsParLignes(4) = 113
NbPointsParLignes(5) = 6
NbPointsParLignes(6) = 17
NbPointsParLignes(7) = 7
NbPointsParLignes(8) = 9
NbPointsParLignes(9) = 16
NbPointsParLignes(10) = 29
NbPointsParLignes(11) = 16
NbPointsParLignes(12) = 24
NbPointsParLignes(13) = 27
NbPointsParLignes(14) = 7
NbPointsParLignes(15) = 8
NbPointsParLignes(16) = 7
NbPointsParLignes(17) = 2
NbPointsParLignes(18) = 38
ReDim Preserve Pts(1 To UBound(Fleuves))
For I = 1 To UBound(Fleuves)
Pts(I) = Projection(Fleuves(I))
Next I
DessinFleuves Pts, NbPointsParLignes
Erase NbPointsParLignes, Pts
End Sub
Public Sub DessinFleuves(ByRef Points() As PointAPI, _
ByRef NbPoints() As Long)
'dessine les fleuves
Dim RetVal As Long
FormeHistoire.Carte.ForeColor = vbBlack
PolyPolyline FormeHistoire.Carte.hdc, Points(1), NbPoints(1), 18
End Sub
Si cela se trouve, il y a beaucoup plus simple.
En tout cas merci de ta réponse et de ta proposition de collaboration.
"christophe-pasde<> @wanadoo.fr>" <"christophe-pasde<> a écrit dans le
message de news: 41a9e3da$0$30448$8fcfb975@news.wanadoo.fr...
Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les API
de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une certaine
logique, ces classes étant interdépendantes pour constituer un modele
objet global de gestion graphique à partir de controle standards VB.
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer de
formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils graphiques,
puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte, enfin
n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais elle
ne sont là que temporairement, de fait j'utilise plutôt des objet Ligne,
TEXT,image,polygone de ma création , qui viennent se dessiner sur un
metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et fonction
inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire des
impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture 'box
pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont 'à
sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
'****************************************************************************
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport '
à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :
Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" <patrice.henrio@laposte.net> a écrit dans le message de
news:OP6UhTT1EHA.3408@tk2msftngp13.phx.gbl...
Je souhaite lancer une discussion sur les API graphiques. En effet malgré
la
lecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créer
des pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As
Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
Bon je vais m'ateler à tout ce travail.
Le sproblèmes de coordonnées ne me posent pas de réels soucis (en tout cas
la partie calcul) car je suis agrégé de maths au départ (et même passionné
de maths).
Dons pour ma part j'utilise un fichier de points en coordonnées terrestres
(longitude de -180 à -180 et latitude de -90 à +90, en degré décimaux).
Ensuite je définis un point central sur la sphère qui sera le point de
tangence d'un plan de projection et de la sphère. En effet je limite l'image
à un carré de 20° au Nord, Sud, Est et Ouest, ce qui me permet de n'avoir
qu'une déformation minime lors de la projection sur le plan. Bien entendu
tout ce qui concerne le relief n'est pas pris en compte.
Je définis des régions et des lignes sur la terre par leurs coordonnées et
les dessine par CreatePolyPolygonRgn, j'utilise toutes les fonctions
nécessaires pour colorier l'intérieur et définir si un point est à
l'intérieur d'une région.
Tu peux voir ce que cela donne en téléchargeant le programme et sa mise à
jour (il faut les deux) à l'adresse
http://scraper.chez.tiscali.fr//index1.htm?histoire.htm
Ensuite je peux te faire parvenir les sources pour ce qui peut t'intéresser
ou surtout que tu comprenne mieux le sproblèmes auxquels je suis confronté.
Les questions en suspens sont donc :
augmenter le nombre de couleurs utilisables et miux comprendre color
colorier une région en bleu et rouge (hâchure) par exemple, ou encore avec
des pointillés.
Je viens de terminer l'écriture du nom du fleuve en écriture cursive qui
suit le parcours du fleuve, mais ce n'est pas transposable pour l'instant
car je considère à l'heure actuelle que ce nom est projeté sur la terre,
traduit donc en coordonnées terrestres (tout cela dans une feuille de
calcul excel) puis stocké dans un fichier binaire.
Lors de l'exécution, le programme remplit un tableau à l'aide du fichier
(une seule lecture avec len), ce tableau est traduit à chaque changement du
point central en coordonnées d'écran et permet ensuite de dessiner avec
polypolyline, le nom du fleuve étant considéré comme faisant partie du
fleuve.
Je te transmets ma procédure DessineFleuves
Public Sub DessineFleuves()
Dim NbPoints As Long, NbLignes As Long, NbPointsParLignes() As Long, Pts()
As PointAPI, _
Index As Integer, I As Integer
NbPoints = 0
'c'est pour l'isntant en phase de test donc le tableau NbPointsParLigne est
rempli à la main
NbLignes = 18
ReDim NbPointsParLignes(1 To NbLignes)
NbPointsParLignes(1) = 198 'UBound(Fleuves)
NbPointsParLignes(2) = 34
NbPointsParLignes(3) = 7
NbPointsParLignes(4) = 113
NbPointsParLignes(5) = 6
NbPointsParLignes(6) = 17
NbPointsParLignes(7) = 7
NbPointsParLignes(8) = 9
NbPointsParLignes(9) = 16
NbPointsParLignes(10) = 29
NbPointsParLignes(11) = 16
NbPointsParLignes(12) = 24
NbPointsParLignes(13) = 27
NbPointsParLignes(14) = 7
NbPointsParLignes(15) = 8
NbPointsParLignes(16) = 7
NbPointsParLignes(17) = 2
NbPointsParLignes(18) = 38
ReDim Preserve Pts(1 To UBound(Fleuves))
For I = 1 To UBound(Fleuves)
Pts(I) = Projection(Fleuves(I))
Next I
DessinFleuves Pts, NbPointsParLignes
Erase NbPointsParLignes, Pts
End Sub
Public Sub DessinFleuves(ByRef Points() As PointAPI, _
ByRef NbPoints() As Long)
'dessine les fleuves
Dim RetVal As Long
FormeHistoire.Carte.ForeColor = vbBlack
PolyPolyline FormeHistoire.Carte.hdc, Points(1), NbPoints(1), 18
End Sub
Si cela se trouve, il y a beaucoup plus simple.
En tout cas merci de ta réponse et de ta proposition de collaboration.
"christophe-pasde<> @wanadoo.fr>" <"christophe-pasde<> a écrit dans le
message de news: 41a9e3da$0$30448$Bonjour,
1) Pour ceux que l'anglais n'effraie pas
il y a microsoft.public.vb.winapi.graphics comme NG
les tutoriaux du principal animateur du NG:
http://edais.mvps.org/
2) Je peux dans la mesure de mes moyens essayer de t'éclairer sur les API
de la GDI (interface graphique).
Etant donné que je n'utilise quasiment que ça pour mes developpements.
3) Je souhaite créer un site contenant les sources des classes VB de ma
composition mais malheureusement je n'ai aucune expérience en la matière
(site Web) et je n'ai pas eu le temps de me pencher sur la question.
NB: si qqun veux donner un coup de main ...
4) Je peux te donner ces sources, mais il te faut entrer dans une certaine
logique, ces classes étant interdépendantes pour constituer un modele
objet global de gestion graphique à partir de controle standards VB.
C'est en projet, pareil si ça interesse qqun, je me propose d'essayer de
formaliser ça sur la base UML avec Poseidon, pour la doc.
Quand je dis entrer dans une certaine logique ce n'est pas uniquement
valable pour mon modèle objet mais pour les API graphiques d'une manière
générale. J'ai étudier ça à l'aide du bouquin de Dan Appleman (VB5 & API
Windows32 introuvable en français maintenant) et ça méthodologie est
excellente.
Il te faut d'abord te familiariser avec les DC et leurs système de
coordonnées, ensuite apprendre à créer et utiliser les outils graphiques,
puis les bitmap si ça t'interresse.
J'insiste sur la partie système de coordonnées, peut-être à cause de mon
métier, mais il n'en demeure pas moins que c'est la base pour utiliser
efficacement toutes les api graphiques.
Ensuite, l'autre partie vitale c'est les régles de création et de
destruction des objets GDI pour une utilisation correcte avec VB, et ne
pas produire des plantages graves.
La règle d'Or : Les DC c'est comme les WC, il faut les laisser dans le
même état en partant qu'en entrant.
Ci-dessous une classe de base permettant d'utiliser le DC d'un picturebox.
Je vais essayer de commenter au maximum les principales fonctions:
Init
setmetrique
exitmetrique
Conversion de coordonnées
Pour le reste testes, ça mord pas.
Tu y trouveras les outils pour dessiner un texte orienté.
Pour l'utiliser:
Dans une Form un picturebox picture1
Dim mdc AS MetricDC
set mdc = new metricDC
mdc.init picture1
[....]
Set mdc=nothing
Pour me comprendre j'appel espace Réel un repère orthonormé où on calcul
des coordonnées en virgule flottante. Comme sur un plan , une carte, enfin
n'importe quel espace 2D.
Le but principale de cet objet et de fournir un contexte d'affichage qui
connait en permanence l'espace réel, logique, périphérique qu'il
représente, et qui est capable d'effectuer une conversion entre ces
espaces. Tu trouveras quelques methode pour dessiner (ligne etc) mais elle
ne sont là que temporairement, de fait j'utilise plutôt des objet Ligne,
TEXT,image,polygone de ma création , qui viennent se dessiner sur un
metricDC.
Si tu calcul dans un autre système (sphérique , pas orthogonal ou autre)
tout le code reste valable sauf la fonction logique vers réel et fonction
inverse qu'il te faudra réecrire.
Ce qui est intéressant avec ce mode de mapping c'est de pouvoir faire des
impressions à l'echelle, en effet le metricDC peut être celui d'une
imprimante, avec une trés légére réecriture pour ne pas utiliser le hwnd
mais le format de papier.
Pour traduire coordonnées périphérique comprend x,y de mouse_down, _UP,
_Move
Dernière chose t'a d'l'a chance que c'est Dimanche (lol)
Christophe
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
'************************************************************
'************************************************************
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
'affecte picture1 au picturebox privé mPicture
Set mPicture = Picture1
mPicture.ScaleMode = 3 ' VBpixel
espaceclient ' recupere le rectangle client du picturebox
' On fixe les variables désignant le coin inférieur gauche du picture 'box
pour origine du port de visualisation
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
'idem pour l'origine de la fenêtre logique
mWinOrgX = 0
mWinOrgY = 0
'initialise l'origine de l'espace Réel et l'echelle de transformation
mxT = 0
myT = 0
mEchelle = 1 / 1000
' sauve l'état du DC et Mappe le DC en mode métrique voir commentaires à
'la fonction
setmetrique
' calcul de l'espace réel représenté par le viewport du DC
' C'est à dire la partie visible du picturebox à l'ecran qui correspont 'à
sa zone client
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
'Convertit les unité de périphérique pixel en unité logique
' en mode métrique une unité logique vaut 0.01 mm
dummy& = DPtoLP(mPicture.hdc&, MaxlogPoint(0), 1)
'Calcul la taille logique de la diagonale du picturebox
'***
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
'***
'Convertit en unité réelles et affecte mespacereel
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
' retour du DC à VB
exitmetrique
' Demande au picture box de représenter la zone réelle, 0,0 (en bas à
'gauche , 1000 mètres 1000 mètres en haut à droite
zoomReel 0, 0, 1000, 1000
End Sub
'****************************************************************************
Public Sub setmetrique()
'enregistre l'état du DC
m_savedDC& = SaveDC&(mPicture.hdc)
'definit le mode de mapping
' Origine inf gauche, Y ascendant, une unité logique = 0.01 mm
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
'définit l'origine du port de visualisation
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
' définit l'origine de la fenêtre logique
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
'************************************************
' retour du DC à l'état initial pour VB
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
' Fonction pour passer des coordonnées périphérique
' Aux coordonnées réelles
' Déclaré single pour pouvoir être utilisé sur Mouse_Move ou down de
'mPicture
Public Sub PeriphReel(x As Single, y As Single)
'toujours effectuer setmetrique
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
'convertit les unité périph en logique
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 1)
' convertit les logiques en réel
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
' fonction réciproque
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc&, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
'*************************************************
' voir RtoL
' limité à 2^16-1 pour win 98
' A limité à 2^32-1 pour système NT
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
End Sub
'******************************** reel vers logique
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
'*********************************************************************
' mxT et myT sont les origines réels du DC à l'instant t
' une unité logique = 10^-5 mètres
' ||p||/mechelle * 10^-5 = distance réelle du point cherché par rapport '
à mxT, myT
Private Function LtoR(p As POINTAPI) As POINTGEO
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc&, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc&, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc&, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc&, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
dummy& = MoveToEx&(mPicture.hdc&, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc&, ap(1).x, ap(1).y)
dummy& = SelectObject(mPicture.hdc&, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
Taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + Taille
p.y = y + Taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get Echelle() As Double
Echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
YannX a écrit :Bnjr Patrice,
Puis-je te suggérer
d'aller voir un outil sympa, http://www.progotop.com/popapi/
avec un forum avec quelques passionnés de ce genre de pb.
http://forum.progotop.com/index.php
C'est pas pour décourager de VB sur MPFV,
mais il y a qq. (pas bcp) "chébrans" exclusifs....
ou aussi VBFrance à partir des sources exemples d'usages
Pour info.
Yann
"Patrice Henrio" a écrit dans le message de
news:Je souhaite lancer une discussion sur les API graphiques. En effet malgré
lalecture de l'API guide, j'ai des problèmes pour savoir tout ce qu'on peut
faire avec ces API.
Je repose donc mon problème : comment utiliser plus de couleurs, RVB,
créerdes pinceaux avec des motifs personnels ...
En particulier j'utilise actuellement :
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" _
(ByVal hdc As Long, _
lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long)
As
Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" _
(lpPoint As PointAPI, _
lpPolyCounts As Long, _
ByVal nCount As Long, _
ByVal nPolyFillMode As
Long)
As Long
Private Declare Function PtInRegion Lib "gdi32" _
(ByVal hRgn As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function FillRgn Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hRgn As Long, _
ByVal hBrush As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias
"RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias
"RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" _
(ByVal hdc As Long, _
lppt As PointAPI, _
lpdwPolyPoints As Long, _
ByVal cCount As Long) As Long
Private Const ALTERNATE = 1
