Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню Заметки | Рисование на UserForm с помощью функций WinAPI


Rambler's Top100


Counter CO.KZ
Если Вам необходимо написать некий текст и/или нарисовать какой-нибудь простенький рисунок, причём это необходимо проделать не в графическом редакторе Paint, а именно на пользовательской форме - UserForm (см. скриншот), то нижеопубликованный код (который необходимо расположить в модуле нужной UserForm) поможет Вам это реализовать. Сам же процесс рисования, собственно, происходит также, как и в Paint.

Комментарий :
  • обратите внимание на необходимость наличия текста в строке заголовка пользовательской формы (свойство Caption), если же информации в строке заголовка быть не должно, то введите один или несколько пробелов.
  • а также, на WinAPI функцию CreatePen, использование которой позволит Вам получить нужный цвет линии crColor, а также её ширину nWidth
  • если же Вас устраивает чёрная линия, шириной в один пиксел, то применение функций CreatePen, SelectObject, DeleteObject не имеет особого смысла. Проще говоря, Вы вполне можете обойтись и без них.



  • Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    
    Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function GetDC _
            Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function CreatePen _
            Lib "gdi32.dll" ( _
            ByVal nPenStyle As Long, _
            ByVal nWidth As Long, _
            ByVal crColor As Long) As Long
    Private Declare Function SelectObject _
            Lib "gdi32.dll" ( _
            ByVal hDC As Long, _
            ByVal hObject As Long) As Long
    Private Declare Function GetCursorPos _
            Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function ScreenToClient _
            Lib "user32.dll" ( _
            ByVal hWnd As Long, _
            lpPoint As POINTAPI) As Long
    Private Declare Function LineTo _
            Lib "gdi32.dll" ( _
            ByVal hDC As Long, _
            ByVal X As Long, _
            ByVal Y As Long) As Long
    Private Declare Function MoveToEx _
            Lib "gdi32.dll" ( _
            ByVal hDC As Long, _
            ByVal X As Long, _
            ByVal Y As Long, _
            lpPoint As POINTAPI) As Long
    Private Declare Function ReleaseDC _
            Lib "user32.dll" ( _
            ByVal hWnd As Long, _
            ByVal hDC As Long) As Long
    Private Declare Function DeleteObject _
            Lib "gdi32.dll" (ByVal hObject As Long) As Long
    
    Private ihWnd&, ihDC&, ihPen&, ihOldPen&, iPoint As POINTAPI
    
    Private Sub UserForm_Initialize()
        ihWnd = FindWindow(vbNullString, Me.Caption)
        ihDC = GetDC(ihWnd)
        
        ihPen = CreatePen(0, 5, RGB(255, 0, 100))
        ihOldPen = SelectObject(ihDC, ihPen)
    End Sub
    
    Private Sub UserForm_MouseMove(ByVal Button As Integer, _
        ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        GetCursorPos iPoint
        ScreenToClient ihWnd, iPoint
    
        If Button = vbKeyLButton Then
           LineTo ihDC, iPoint.X, iPoint.Y
        Else
           MoveToEx ihDC, iPoint.X, iPoint.Y, iPoint
        End If
    End Sub
    
    Private Sub UserForm_MouseUp(ByVal Button As Integer, _
        ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        UserForm_MouseMove Button, Shift, X, Y
    End Sub
    
    Private Sub UserForm_Terminate()
        ReleaseDC ihWnd, ihDC
        DeleteObject ihPen
    End Sub
    Разумеется, мы можем и минимизировать количество вызовов WinAPI функции MoveToEx, если будем использовать её только при нажатии на левую кнопку мышки, т.е.
    Private Sub UserForm_MouseMove(ByVal Button As Integer, _
        ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        If Button = vbKeyLButton Then
           GetCursorPos iPoint
           ScreenToClient ihWnd, iPoint
           LineTo ihDC, iPoint.X, iPoint.Y
        End If
    End Sub
    
    Private Sub UserForm_MouseDown(ByVal Button As Integer, _
        ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        GetCursorPos iPoint
        ScreenToClient ihWnd, iPoint
        MoveToEx ihDC, iPoint.X, iPoint.Y, iPoint
    End Sub




    Пример можно скачать здесь




    Автор : Климов Павел Юрьевич
    © 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff