Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - Общий форум

Страница: 1 | 2 |

 

  Вопрос: Создание собственного меню Добавлено: 24.06.14 13:29  

Автор вопроса:  Vitalysan®
Доброго всем времени. Пытаюсь создать меню. Проблема в моментах прорисовки...Для начала код.
Модуль:
Option Explicit

Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1

Public Const WM_LBUTTONDOWN = &H201

Private Type POINTAPI
    X                               As Long
    Y                               As Long
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type CBTACTIVATESTRUCT
    fMouse As Long
    hWndActive As Long
End Type


Public ParentHwnd As Long
Public ContHwnd As Long
Public hHook As Long
 
Dim CBT As CBTACTIVATESTRUCT

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Public Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lngHandle As Long
    Dim lpPoint As POINTAPI
    CopyMemory CBT, ByVal lParam, Len(CBT)
    Select Case CBT.fMouse
        Case WM_LBUTTONDOWN
            Call GetCursorPos(lpPoint)
            lngHandle = WindowFromPoint(lpPoint.X, lpPoint.Y)
            If lngHandle <> ContHwnd Then Call HideContainer
    End Select
    HookProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

Sub HideContainer()
    Dim rc As RECT
    Dim p As POINTAPI
    GetWindowRect ContHwnd, rc
    p.X = rc.Left: p.Y = rc.Top
    ScreenToClient ParentHwnd, p
    SetParent ContHwnd, ParentHwnd
    MoveWindow ContHwnd, p.X, p.Y, rc.Right - rc.Left, 20, True
    Call UnhookWindowsHookEx(hHook)
End Sub


Usercontrol:
Option Explicit

Private Const WH_JOURNALRECORD = 0

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
'Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long

Private Sub OpenContainer()
    Dim rc As RECT
    ContHwnd = hWnd
    ParentHwnd = Parent.hWnd
    If ScaleHeight = 20 Then
        GetWindowRect hWnd, rc
        SetParent hWnd, 0
        MoveWindow hWnd, rc.Left, rc.Top, ScaleWidth, 100, True
        SetWindowPos hWnd, -1, rc.Left, rc.Top, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
        hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0)
    Else
        Call HideContainer
    End If
End Sub

Private Sub UserControl_Click()
    OpenContainer
End Sub

Private Sub UserControl_Initialize()
    SetWindowLong hWnd, GWL_EXSTYLE, WS_EX_TOOLWINDOW Or GetWindowLong(hWnd, GWL_EXSTYLE)
End Sub

'Private Sub UserControl_Paint()
'    Line (0, 0)-(ScaleWidth, 0)
'    If Ambient.UserMode = False Then Exit Sub
'    InvalidateRect hWnd, 0, False
'End Sub

Private Sub UserControl_Resize()
    Width = 100 * Screen.TwipsPerPixelX
    Height = 20 * Screen.TwipsPerPixelY
End Sub

Private Sub UserControl_Terminate()
    Call UnhookWindowsHookEx(hHook)
End Sub


Проблемы следующие:
Если ставить свойство контрола Autoredraw=false, то линия "моргает", если Autoredraw=true, то тогда "моргает" контрол. А при нажатии на заголовок формы вообще исчезает на некоторое время.
Line привёл для примера. Впоследствии собираюсь пользоваться FillRect'ом...

Ответить

  Ответы Всего ответов: 18  

Номер ответа: 1
Автор ответа:
 AWP



ICQ: 345685652 

Вопросов: 96
Ответов: 1212
  Web-сайт: xawp.narod.ru
 Профиль | | #1 		Добавлено: 24.06.14 14:27
А если прорисовку кинуть в UserControl_Paint ?

Ответить

Номер ответа: 2
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #2 Добавлено: 24.06.14 16:37
В коде у меня закомментирована эта процедура. Если использовать InvalidateRect или RedrawWindow, тогда Line "моргает". В противном случае, "моргает" контрол

Ответить

Номер ответа: 3
Автор ответа:
 vito



Разработчик Offline Client

Вопросов: 23
Ответов: 879
  Web-сайт: softvito.narod2.ru
 Профиль | | #3 		Добавлено: 24.06.14 20:56
  1. Line (0, 0)-(ScaleWidth, 0)


ScaleWidth - переменная. Линия и должна моргать????

Ответить

Номер ответа: 4
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #4 Добавлено: 25.06.14 14:01
Линия и должна моргать????
Если это вопрос, то нет, не должна. Итогом должен быть таким: ни контрол, ни то, что "лежит" на контроле моргать не должно. Добиться того, чтобы не "моргал" контрол, у меня получается в случае, если свойство контрола Autoredraw = False и в процедуре UserControl_Paint прописано InvalidateRect. Но тогда на контроле ничего не нарисуешь, не зальёшь FillRect'ом....

Ответить

Номер ответа: 5
Автор ответа:
 vito



Разработчик Offline Client

Вопросов: 23
Ответов: 879
  Web-сайт: softvito.narod2.ru
 Профиль | | #5 		Добавлено: 25.06.14 16:05
InvalidateRect hWnd, 0, False при последнем параметре false не должна обновлять фон.
Только, если мне не изменяет память, прорисовка идет в парах BeginPaint … EndPaint, которые вызываются после InvalidateRect.

То есть импортируй эти функции, и вызови после InvalidateRect.

Ответить

Номер ответа: 6
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #6 Добавлено: 25.06.14 16:33
BeginPaint … EndPaint
Благодарю за советы, но не помогает:
  1. Private Sub UserControl_Paint()
  2.     InvalidateRect hWnd, 0, False
  3.     Dim rc As RECT
  4.     Dim ps As PAINTSTRUCT
  5.     Call BeginPaint(hWnd, ps)
  6.     SetRect rc, 0, 0, 100, 20
  7.     pFillRect hDC, rc, RGB(128, 128, 128)
  8.     EndPaint hWnd, ps
  9. End Sub
  10.  


Если контрол не трогать, то прорисовка идёт. Если вызывать OpenContainer - начинается "моргание". И при "открытом" контроле при нажатии на заголовок формы, контрол исчезает на некоторое время.

Ответить

Номер ответа: 7
Автор ответа:
 vito



Разработчик Offline Client

Вопросов: 23
Ответов: 879
  Web-сайт: softvito.narod2.ru
 Профиль | | #7 		Добавлено: 25.06.14 19:48
  1. If ScaleHeight = 20 Then
  2.         GetWindowRect hWnd, rc
  3.         SetParent hWnd, 0
  4.         MoveWindow hWnd, rc.Left, rc.Top, ScaleWidth, 100, True
  5.         SetWindowPos hWnd, -1, rc.Left, rc.Top, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
  6.         hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0)
  7.     Else
  8.         Call HideContainer
  9.     End If


Моргание или исчезание ошибка логики.

If ScaleHeight = 20
выполняется не всегда.
А значит вызывается HideContainer

Условия нужно уточнить.
  1. If ScaleHeight = 20 Then
  2. ...
  3.  
  4. Else If (конкретизация)
  5.      Call HideContainer
  6. End If


После конкретизации одна из проблем должна исчезнуть и будет понятно что делать дальше .

Ответить

Номер ответа: 8
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #8 Добавлено: 26.06.14 11:44
Может я не совсем понял, но Debug.Print сообщает только 2 значения: 20 и 100

Ответить

Номер ответа: 9
Автор ответа:
 vito



Разработчик Offline Client

Вопросов: 23
Ответов: 879
  Web-сайт: softvito.narod2.ru
 Профиль | | #9 		Добавлено: 26.06.14 19:06
Вопрос в том в какой очередности и с какой частотой он их сообщает. Время выполнения API неопределенно.

Логика сейчас.
Если 20 -> Открываем. В любом другом случае(100), закрываем.
Т.е. закрытие может быть вызвано в процессе открытия. А потом опять вызвано открытие.
Или несколько раз вызвано открытие/закрытие(Такое тоже может быть).
 

Нужно.
1. Открываем. Если закрыто(флаг или возвращаемое API значение, например hHook) и UserControl_Click.
3. Закрываем. Наоборот – если открыто и UserControl_Click.
3. (Желательно) Если открываем (в процессе), то не закрываем и не открываем повторно. Если закрываем(в процессе) то не открываем и не закрываем повторно.

Ответить

Номер ответа: 10
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #10 Добавлено: 27.06.14 19:57
Я пока додумался только до этого:
  1. Private Sub OpenContainer()
  2.     Dim rc As RECT
  3.     ContHwnd = hWnd
  4.     ParentHwnd = Parent.hWnd
  5.     If ScaleHeight = 20 Then
  6.         GetWindowRect hWnd, rc
  7.         SetParent hWnd, 0
  8.         MoveWindow hWnd, rc.Left, rc.Top, ScaleWidth, 100, True
  9.         SetWindowPos hWnd, -1, rc.Left, rc.Top, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
  10.         hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0)
  11.     ElseIf ScaleHeight = 100 Then
  12.         Call HideContainer
  13.     ElseIf ScaleHeight <> 20 And ScaleHeight <> 100 Then Exit Sub
  14.     End If
  15. End Sub
больше придумать ничего не могу :(

Ответить

Номер ответа: 11
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #11 Добавлено: 27.06.14 19:59
Ещё соображения поставить дополнительный хук на контрол, но чувствую будут другие проблемы...

Ответить

Номер ответа: 12
Автор ответа:
 vito



Разработчик Offline Client

Вопросов: 23
Ответов: 879
  Web-сайт: softvito.narod2.ru
 Профиль | | #12 		Добавлено: 28.06.14 00:19
Получше стало? Думаю что не очень.
И я синтаксис VB подзабыл :)

  1. Private Sub UserControl_Click()
  2.  
  3.  If hHook == (null) // контейнер закрыт
  4.     OpenContainer
  5. Else if hHook != (null) //контейнер открыт
  6.     HideContainer()
  7. End Sub



  1. Private Sub OpenContainer()
  2.     Dim rc As RECT
  3.     ContHwnd = hWnd
  4.     ParentHwnd = Parent.hWnd
  5.         GetWindowRect hWnd, rc
  6.         SetParent hWnd, 0
  7.         MoveWindow hWnd, rc.Left, rc.Top, ScaleWidth, 100, True
  8.         SetWindowPos hWnd, -1, rc.Left, rc.Top, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
  9.         hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0)
  10. End Sub


hHook при старте инициализируй.

Ответить

Номер ответа: 13
Автор ответа:
 EROS



Вопросов: 58
Ответов: 4255
  Профиль | | #13 Добавлено: 28.06.14 14:29
прекратите насиловать труп VB (с) Sharp

Ответить

Номер ответа: 14
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #14 Добавлено: 29.06.14 08:51
Получше стало? Думаю что не очень
Да, не стало...и предложенный вариант тоже также глючит. Пробовал хукать контрол - моргание исчезло, но при нажатии на заголовок формы срабатывает событие Usercontrol_MouseDown. Плюс на контроле будет таймер и с ним тоже проблемы, но об этом не сейчас...

Ответить

Номер ответа: 15
Автор ответа:
 Vitalysan®



Вопросов: 25
Ответов: 61
  Профиль | | #15 Добавлено: 29.06.14 08:54
прекратите насиловать труп VB (с) Sharp
Согласен. Но для перемещения предмета с места на место не важен язык программирования. Не сложно изучить синтаксис другого языка, сложнее решить поставленную задачу.

Ответить

Страница: 1 | 2 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам