Thomas Risi Softwareentwicklung
Addins - Datenbanklösungen - Komponenten - RTDServer - WebServices
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
GetHandle = FindWindow("ThunderXFrame", vbNullString)
Case 9, 10, 11
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
© 2001 -
by Thomas Risi