Créer une horloge [Sources]

**luuuuuc** · 12/12/2005, 16h19

Salut a tous
Voila cela fait un petit moment que je vien sur ce site rechercher des reponse mais cette fois je ne trouve pas la solution a mon probleme.
Je suis en train de créer une base de données sur acces et je souhaite insérer une horloge dans un formulaire avec la trotteuse qui défile.
Je recherche donc un petit cout de main
merci

**Lou Pitchoun** · 12/12/2005, 16h37

Salut et bienvenu sur le forum
1) as tu fais une recherche ???
je pense pas....
sinon tu aurais trouvé ceci....

Les règles du forum

**Arkham46** · 12/12/2005, 21h03

Slt,

Le lien de Kikof c'est du Vb.net donc marche pas avec access....

Pour rire un peu je l'ai passé sur access, non sans mal mais j'avais un truc en cours pour créer des images dynamiquement dans des contrôles images.
Enfin bref voilà une horloge :
- c'est testé en access 2000, les autres versions c'est à tester.
- à mettre dans un module de classe, nommé ClHorloge

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
Option Compare Database
Option Explicit
 
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) 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) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BitmapInfo8, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As _
                                              Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" _
                                           (ByVal OLE_COLOR As Long, _
                                            ByVal HPALETTE As Long, _
                                            pccolorref As Long) As Long
Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" _
                                    (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, _
                                     lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) As Long
 
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Const DT_SINGLELINE = &H20
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const TRANSPARENT = 1
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BitmapInfo8
    bmiHeader As BitmapInfoHeader
    bmiColors(0 To 255) As Long
End Type
Private Type DIBSECTION
    dsBm As BITMAP
    dsBmih As BitmapInfoHeader
    dsBitfields(2) As Long
    dshSection As Long
    dsOffset As Long
End Type
Private Const BI_RGB As Long = &H0
Private Const DIB_RGB_COLORS As Long = &H0
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private TailleAiguille As Integer
Private ImgCtrl As Access.Image
Public CouleurNumero As Long
Public CouleurFond As Long
Public CouleurHorloge As Long
Public CouleurHeure As Long
Public CouleurMinute As Long
Public CouleurSeconde As Long
Public AfficheNumero As Boolean
Public Function Set_Clock_Ctrl(ctrl As Access.Image)
    Set ImgCtrl = ctrl
    TailleAiguille = 0.8 * 0.5 * IIf(ImgCtrl.Width < ImgCtrl.Height, TwipsToPixelX(ImgCtrl.Width), TwipsToPixelY(ImgCtrl.Height))
End Function
Public Function PaintClock()
    On Error Resume Next
    Dim bmp As BitmapInfo8
    Dim cpt As Integer
    Dim hDIB As Long
    Dim hdc As Long
    Dim DIBPtr As Long
    Dim NewBrush As Long
    Dim NewPen As Long
    Dim OldBrush As Long
    Dim rc As RECT
    Dim PicData() As Byte
    Dim DS As DIBSECTION
    Dim NbRow As Integer
    Dim d As Date
    Dim n, z, u, x0, y0, x1, y1, x2, y2, x3, y3 As Single
    Dim aigPoints(3) As POINTAPI
    Dim text As String
    d = Now
    hdc = CreateCompatibleDC(GetDC(ImgCtrl.Parent.hwnd))
    SetBkMode hdc, TRANSPARENT
    bmp.bmiHeader.biSize = Len(bmp.bmiHeader)
    bmp.bmiHeader.biHeight = TwipsToPixelY(ImgCtrl.Height)
    bmp.bmiHeader.biWidth = TwipsToPixelX(ImgCtrl.Width)
    bmp.bmiHeader.biCompression = BI_RGB
    bmp.bmiHeader.biBitCount = 24
    bmp.bmiHeader.biPlanes = 1
    bmp.bmiHeader.biSizeImage = bmp.bmiHeader.biWidth * Abs(bmp.bmiHeader.biHeight) * (bmp.bmiHeader.biBitCount + 7) / 8
    rc.Left = 0
    rc.Right = bmp.bmiHeader.biWidth
    rc.Top = 0
    rc.Bottom = bmp.bmiHeader.biHeight
    hDIB = CreateDIBSection(hdc, bmp, DIB_RGB_COLORS, DIBPtr, 0, 0)
    Call SelectObject(hdc, hDIB)
    NewBrush = CreateSolidBrush(GetColor(CouleurFond, RGB(180, 255, 180)))
    Call FillRect(hdc, rc, NewBrush)
    DeleteObject NewBrush
    NewBrush = CreateSolidBrush(GetColor(CouleurHorloge, RGB(150, 150, 255)))
    Call SelectObject(hdc, NewBrush)
    Call SetTextColor(hdc, 255)
    Call Ellipse(hdc, 0.1 * bmp.bmiHeader.biWidth, 0.1 * bmp.bmiHeader.biHeight, 0.9 * bmp.bmiHeader.biWidth, 0.9 * bmp.bmiHeader.biHeight)
    DeleteObject NewBrush
    ' Traits
    For cpt = 1 To 12
        n = cpt * 200 / 12
        z = n / 100 * 3.14159
        rc.Left = bmp.bmiHeader.biWidth * (0.5 + CSng(Math.Sin(z)) * 0.4)
        rc.Top = bmp.bmiHeader.biHeight * (0.5 + CSng(-Math.Cos(z)) * 0.4)
        rc.Right = bmp.bmiHeader.biWidth
        rc.Bottom = bmp.bmiHeader.biHeight
        Call Ellipse(hdc, rc.Left - 2, rc.Top - 2, rc.Left + 2, rc.Top + 2)
    Next cpt
    ' Numéros
    If AfficheNumero Then
        SetTextColor hdc, GetColor(CouleurNumero, RGB(0, 100, 100))
        For cpt = 1 To 12
            n = cpt * 200 / 12
            z = n / 100 * 3.14159
            rc.Left = bmp.bmiHeader.biWidth * (0.5 + CSng(Math.Sin(z)) * 0.45) - 13
            rc.Top = bmp.bmiHeader.biHeight * (0.5 + CSng(-Math.Cos(z)) * 0.45) - 5
            rc.Right = rc.Left + 20
            rc.Bottom = rc.Top + 10
            text = Str(cpt)
            DrawTextEx hdc, text, Len(text), rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, ByVal 0
        Next cpt
    End If
    ' Aiguille des Minutes
    n = DatePart("n", d) * 200 / 60
    z = n / 100 * 3.14159
    u = (n + 50) / 100 * 3.14159
 
    x0 = CSng(Math.Sin(z)) * TailleAiguille * 0.8
    y0 = CSng(-Math.Cos(z)) * TailleAiguille * 0.8
 
    x1 = CSng(-Math.Sin(z)) * 10
    y1 = CSng(Math.Cos(z)) * 10
 
    x2 = CSng(Math.Sin(u)) * 4
    y2 = CSng(-Math.Cos(u)) * 4
 
    x3 = CSng(-Math.Sin(u)) * 4
    y3 = CSng(Math.Cos(u)) * 4
 
    aigPoints(0).X = x1 + bmp.bmiHeader.biWidth / 2
    aigPoints(0).Y = y1 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(1).X = x2 + bmp.bmiHeader.biWidth / 2
    aigPoints(1).Y = y2 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(2).X = x0 + bmp.bmiHeader.biWidth / 2
    aigPoints(2).Y = y0 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(3).X = x3 + bmp.bmiHeader.biWidth / 2
    aigPoints(3).Y = y3 + bmp.bmiHeader.biHeight / 2
    NewBrush = CreateSolidBrush(GetColor(CouleurMinute, RGB(0, 255, 0)))
    Call SelectObject(hdc, NewBrush)
    Call Polygon(hdc, aigPoints(0), 4)
    DeleteObject NewBrush
    ' Aiguille des Heures
    n = DatePart("h", d) * 200 / 12 + DatePart("n", d) * 200 / 60 / 12
    z = n / 100 * 3.14159
    u = (n + 50) / 100 * 3.14159
 
    x0 = CSng(Math.Sin(z)) * TailleAiguille * 0.5
    y0 = CSng(-Math.Cos(z)) * TailleAiguille * 0.5
 
    x1 = CSng(-Math.Sin(z)) * 10
    y1 = CSng(Math.Cos(z)) * 10
 
    x2 = CSng(Math.Sin(u)) * 4
    y2 = CSng(-Math.Cos(u)) * 4
 
    x3 = CSng(-Math.Sin(u)) * 4
    y3 = CSng(Math.Cos(u)) * 4
 
    aigPoints(0).X = x1 + bmp.bmiHeader.biWidth / 2
    aigPoints(0).Y = y1 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(1).X = x2 + bmp.bmiHeader.biWidth / 2
    aigPoints(1).Y = y2 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(2).X = x0 + bmp.bmiHeader.biWidth / 2
    aigPoints(2).Y = y0 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(3).X = x3 + bmp.bmiHeader.biWidth / 2
    aigPoints(3).Y = y3 + bmp.bmiHeader.biHeight / 2
 
    NewBrush = CreateSolidBrush(GetColor(CouleurHeure, RGB(255, 0, 0)))
    Call SelectObject(hdc, NewBrush)
    Call Polygon(hdc, aigPoints(0), 4)
    DeleteObject NewBrush
    ' Aiguille des secondes
    n = DatePart("s", d) * 200 / 60
    z = n / 100 * 3.14159
    u = (n + 50) / 100 * 3.14159
 
    x0 = CSng(Math.Sin(z)) * TailleAiguille * 0.9
    y0 = CSng(-Math.Cos(z)) * TailleAiguille * 0.9
 
    x1 = CSng(-Math.Sin(z)) * 10
    y1 = CSng(Math.Cos(z)) * 10
 
    x2 = CSng(Math.Sin(u)) * 1
    y2 = CSng(-Math.Cos(u)) * 1
 
    x3 = CSng(-Math.Sin(u)) * 1
    y3 = CSng(Math.Cos(u)) * 1
 
    aigPoints(0).X = x1 + bmp.bmiHeader.biWidth / 2
    aigPoints(0).Y = y1 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(1).X = x2 + bmp.bmiHeader.biWidth / 2
    aigPoints(1).Y = y2 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(2).X = x0 + bmp.bmiHeader.biWidth / 2
    aigPoints(2).Y = y0 + bmp.bmiHeader.biHeight / 2
 
    aigPoints(3).X = x3 + bmp.bmiHeader.biWidth / 2
    aigPoints(3).Y = y3 + bmp.bmiHeader.biHeight / 2
    NewBrush = CreateSolidBrush(IIf(CouleurSeconde = 0, RGB(255, 255, 255), CouleurSeconde))
    Call SelectObject(hdc, NewBrush)
    Call Polygon(hdc, aigPoints(0), 4)
    DeleteObject NewBrush
    ' PictureData
    Call apiGetObject(hDIB, Len(DS), DS)
    ReDim PicData(DS.dsBmih.biSizeImage + 40)
    RtlMoveMemory PicData(40), ByVal DIBPtr, DS.dsBmih.biSizeImage
    RtlMoveMemory PicData(0), DS.dsBmih, 40
    ImgCtrl.PictureData = PicData
    DeleteDC hdc
    DeleteObject DIBPtr
    DeleteObject hDIB
End Function
Private Function GetColor(Color As Long, DefaultColor As Long) As Long
    If Color = -1 Then
        Color = DefaultColor
    End If
    If Color < 0 Then
        Call OleTranslateColor(Color, 0, Color)
    End If
    GetColor = Color
End Function
' Convertir les twips en pixels pour les APIs
Private Function TwipsToPixelX(X As Long) As Long
    Static mult As Long
    Dim hdc As Long
    If mult = 0 Then
        hdc = GetDC(0)
        mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSX)
        ReleaseDC 0, hdc
    End If
    TwipsToPixelX = CLng(X / mult)
End Function
Private Function TwipsToPixelY(Y As Long) As Long
    Static mult As Long
    Dim hdc As Long
    If mult = 0 Then
        hdc = GetDC(0)
        mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    TwipsToPixelY = CLng(Y / mult)
End Function
 
Private Sub Class_Initialize()
    CouleurNumero = -1
    CouleurHorloge = -1
    CouleurHeure = -1
    CouleurMinute = -1
    CouleurSeconde = -1
    CouleurNumero = -1
    AfficheNumero = False
End Sub

- Et dans le formulaire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Compare Database
Option Explicit
 
Private ClHrlg As New ClHorloge
 
Private Sub Form_Load()
    ClHrlg.Set_Clock_Ctrl Me.Image0
    ClHrlg.CouleurFond = Me.Section(acDetail).BackColor
    ClHrlg.CouleurNumero = 0
    ClHrlg.AfficheNumero = False
End Sub
 
Private Sub Form_Timer()
    ClHrlg.PaintClock
End Sub

Avec le timer du formulaire régler à 1000 (toutes les secondes)
Et Image0 qui est le nom de mon contrôle image dans lequel je dessine l'horloge.
Pour créer l'image il faut lui donner un chemin vers un fichier, peu importe le fichier vu qu'on va dessiner dessus donc une image vide c'est le mieux...

Désolé c'est pas documenté et l'écriture du code n'est pas optimiseée j'avais pas envie aujourd'hui...
Y a de quoi l'améliorer mais c'est un bon début....

**User** · 12/12/2005, 22h01

Salut,

Concernant ton code Arkham,

Sous Access 97 j'ai 1 problème avec le type Bitmap non reconnu, quelle librairie dois-je référencer ???

si tu as une idée

@+

**Arkham46** · 12/12/2005, 22h52

arf, j'avais des déclarations publiques dans un autre module....

j'ai corrigé le code.

**User** · 12/12/2005, 23h00

Excellent,

ca fonctionne a merveille,

mais j'y pense il doit bien y avoir des active X qui font le même travail ???

@+

**Arkham46** · 12/12/2005, 23h28

oui peut-être bien qu'il y a des activex mais c'est un bon exercice pour comprendre les API gdi et on peut même changer les couleurs.

Et là je suis un peu malade alors j'ai du temps à perdre...

**Lou Pitchoun** · 13/12/2005, 07h49

Salut,

Envoyé par Arkham46

Le lien de Kikof c'est du Vb.net donc marche pas avec access....

Ben désolé.. mais bon j'ai trouvé ce topic sur le forum access.... et le lien dans le topic a été trouvé par User
Par contre, ça pourrait faire une entrée dans les sources non ???

**luuuuuc** · 13/12/2005, 09h22

ok merci pour les renseignement je vais essayé

**Tofalu** · 13/12/2005, 11h18

Par contre, ça pourrait faire une entrée dans les sources non

Oui, en effet

**PhRey** · 31/12/2006, 17h34

Je deterre ce post pour remercier Arkham !
J'ai utilisé cette horloge dans un formulaire sous access2000.

Utilisé ensuite en sousformulaire, integré dans un formulaire de ma base client, c'est vraiment impec !

PS : si y a un moyen simple de changer les couleurs de cette super horolge je suis preneur egalement !

Encore bravo, et merci a toi !

**jawed** · 31/12/2006, 17h49

salut
je vien de lire cette discussion est ca m'interesse mais est il possible que cette Horloge siot foncionel on dehor d'access sois sur le bureau de mon pc

A+

**ft035580** · 31/12/2006, 17h58

Salut,

Envoyé par PhRey

PS : si y a un moyen simple de changer les couleurs de cette super horolge je suis preneur egalement !

Il suffit de lire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 NewBrush = CreateSolidBrush(GetColor(CouleurFond, RGB(180, 255, 180)))
...
NewBrush = CreateSolidBrush(GetColor(CouleurHorloge, RGB(150, 150, 255)))
....
' Numéros
    If AfficheNumero Then
        SetTextColor hdc, GetColor(CouleurNumero, RGB(0, 100, 100))
... 
etc

Tu modifies les valeurs mauves

**PhRey** · 03/01/2007, 13h55

Yessss ! Merci bcp !

Créer une horloge [Sources]

Access

Discussions similaires

Partager

Partager