Thomas Risi Softwareentwicklung

Zeichnen in UserForm

Entstanden aus einer Frage in einem Forum ...

Es sollen Linien in eine UserForm gezeichnet werden. Hier eine kleine Klasse, die ich schnell 'aus Resten zusammengeklickt' habe. Kopieren Sie den Quellcode für die Klasse in ein neues Klassenmodul und nennen Sie es 'cGDI'.


Code Für Klassenmodul ...

Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetDC Lib "user32" ( _ ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" ( _ ByVal hWnd As Long, ByVal hDC As Long) 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 CreateSolidBrush Lib "gdi32.dll" ( _ ByVal crColor As Long) As Long Private Declare Function DeleteObject Lib "gdi32" ( _ ByVal hObject As Long) As Long Private Declare Function MoveToEx Lib "gdi32" ( _ ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) 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 Polygon Lib "gdi32" ( _ ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long Private Declare Function SelectObject Lib "gdi32" ( _ ByVal hDC As Long, ByVal hObject As Long) As Long Private Type POINTAPI X As Long Y As Long End Type Private Const DEFAULT_PENCOLOR& = 0 Private Const DEFAULT_PENWIDTH& = 2 Private m_hBrush As Long Private m_hDC As Long Private m_hPen As Long Private m_hWnd As Long Private m_hObject As Long Private m_PenWidth As Long Private m_PenColor As Long Private WithEvents m_UserForm As MSForms.UserForm Public Sub Create(UF As MSForms.UserForm) Set m_UserForm = UF m_hWnd = GetHandle m_hDC = GetDC(m_hWnd) End Sub Public Property Get hDC() As Long hDC = m_hDC End Property Public Property Get hWnd() As Long hWnd = m_hWnd End Property Public Property Get PenColor() As Long PenColor = m_PenColor End Property Public Property Let PenColor(c As Long) m_PenColor = c End Property Public Property Get PenWidth() As Long PenWidth = m_PenWidth End Property Public Property Let PenWidth(w As Long) m_PenWidth = w End Property Public Sub DrawLine(X1&, Y1&, X2&, Y2&, Optional Width, Optional Color) If Not IsMissing(Width) Then _ m_PenWidth = Width If Not IsMissing(Color) Then _ m_PenColor = Color If m_hDC Then Dim myPoint As POINTAPI m_hPen = CreatePen(0, m_PenWidth, m_PenColor) m_hObject = SelectObject(m_hDC, m_hPen) Call MoveToEx(m_hDC, X1, Y1, myPoint) Call LineTo(m_hDC, X2, Y2) Call DeleteObject(m_hPen) End If End Sub Private Function GetHandle() As Long Select Case Int(Val(Application.Version)) Case 8 'Excel 97 GetHandle = FindWindow("ThunderXFrame", vbNullString) Case 9, 10, 11 'Excel 2000, XP, 2003 GetHandle = FindWindow("ThunderDFrame", vbNullString) End Select End Function Private Sub Class_Initialize() m_hDC = 0 m_PenColor = DEFAULT_PENCOLOR m_PenWidth = DEFAULT_PENWIDTH End Sub Private Sub Class_Terminate() ReleaseDC m_hWnd, m_hDC End Sub

Beispiel-Code für UserForm mit zwei CommandButtons ...

Option Explicit Dim gdi As cGDI Private Sub CommandButton1_Click() Static n&: n = n + 20 If Not gdi Is Nothing Then With gdi .PenColor = RGB(0, 255, 0) Call .DrawLine(50, n, 150, n, 5) End With End If End Sub Private Sub CommandButton2_Click() Static n&: n = n + 20 If Not gdi Is Nothing Then With gdi .PenColor = RGB(0, 0, 255) Call .DrawLine(150, n, 250, n, 5) End With End If End Sub Private Sub UserForm_Initialize() Set gdi = New cGDI If Not gdi Is Nothing Then _ gdi.Create Me End Sub Private Sub UserForm_Terminate() Set gdi = Nothing End Sub

Bewerten Sie bitte dieses Programm.
1 2 3 4 5
Weniger nützlich Sehr nützlich
Bitte teilen Sie uns mit, warum Sie das Programm so bewertet haben. (optional)