Objet "line" dans une userform

Question

Bonjour,

Voila une grosse galère pour moi, je cherche a faire un userform avec un affichage de tableau de bord type "compteur de voiture" ou "cockpit".

Problème, avec ma version vb6.3, je n'arrive pas à avoir dans la partie "controles supplémentaires" dans ma boite a outils l'objet "line" afin de créer l'aiguille du compteur.

J'ai pourtant fouillé la bibliothèque, il n'y a rien à faire.

Quelqu'un peut il m'aider??

Merci

Nicolas

cs_Jack · Answer

Salut
VB 6.3 : Ce doit être du VBA ?
Tu travailles avec quel logiciel ? Excel, Word ou Access  ?

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

<hr />Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)

bentzwanaman · Answer

oui c'est bien du VBA.


je travaille sur excel


Merci de ton aide.

cs_lermite222 · Answer

J'ai bien une solution mais c'est assez compliqué et ca fait appel aux API, si ca t'intéresse tu dit.

bentzwanaman · Answer

sans problème,
je suis interessé par toute solution,  je suis bloqué et il faut que j'avance...
merci

cs_lermite222 · Answer

Pour le test ouvre un nouveau classeur et ajouter un UF

'Mode d'emploi...
'dans le module de feuille mettre
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'    'activer un UC et dessiner dessus (trouver sont HDC)
'    UserForm1.Show
'End Sub

'2 modes, si la nouvelle sélection est A1 ou pas
'Sur la feuille sélectionner B1 pour mode 1
'Trace une ligne en suivant le déplacement de la souris.
'Sélectionner A1 pour mode 2
'Trace une ligne à partir d'un point central jusqu'a la position souris.
'Et efface la ligne précedante.


'Dans le module de l'UF1 mettre.....
Const PS_SOLID = 0
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, _
  ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long


Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
Private monhdc As Long
Dim Buff As Boolean
Dim TimeOnOFF As Boolean
Dim CurX As Integer, CurY As Integer
Dim ModeLigne As Boolean
Dim coul As Long


Private Sub UserForm_Activate()
    If ActiveCell.Address = "$A$1" Then
        CurX = Me.Width / 2
        CurY = Me.Height / 2
        coul = &H80C0FF
        Me.BackColor = coul
        ModeLigne = True
    End If
End Sub


Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Buff = True
End Sub


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not ModeLigne Then
        Do While monhdc = 0
            monhdc = GetForegroundWindow()
            monhdc = GetDC(monhdc)
        Loop
        If Button <> 1 Then Exit Sub
        hRPen = CreatePen(PS_SOLID, 10, RGB(0, 255, 0))
        DeleteObject SelectObject(monhdc, hRPen)
        If Buff Then
            MoveToEx monhdc, X * 1.32, Y * 1.32, &H0
            Buff = False
        End If
        LineTo monhdc, X * 1.32, Y * 1.32
        DoEvents
    End If
End Sub




Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Static MX As Integer
Static MY As Integer
    
    If ModeLigne Then
        Do While monhdc = 0
            monhdc = GetForegroundWindow()
            monhdc = GetDC(monhdc)
        Loop
        If MX > 0 Then
            hRPen = CreatePen(PS_SOLID, 10, coul)
            DeleteObject SelectObject(monhdc, hRPen)
            MoveToEx monhdc, CurX * 1.32, CurY * 1.32, &H0
            LineTo monhdc, MX * 1.32, MY * 1.32
        End If
        hRPen = CreatePen(PS_SOLID, 6, RGB(0, 255, 0))
        DeleteObject SelectObject(monhdc, hRPen)
        MoveToEx monhdc, CurX * 1.32, CurY * 1.32, &H0
        LineTo monhdc, X * 1.32, Y * 1.32
    End If    MX X: MY Y
End Sub

A toi de voir pour sélectionner les points X et Y
A+

Objet "line" dans une userform

5 réponses

Votre réponse

Discussions similaires