Ты лучше пример кода дай. Я впервые о таком слышу, а API использую не первый день

Ответить

Я не могу отправить примеры по почте - я не из дома, а открывать доступ к моей почте я не хочу (через OUTLOOK). Отсылаю 3 примера:

--------------

----Resize----

--------------

-------------

-=Код формы=-

-------------

Option Explicit

Private Sub Form_Load()

Me.Height = 500 * Screen.TwipsPerPixelY

Me.Width = 500 * Screen.TwipsPerPixelX

'стартуем

Hook Me.hwnd, 100, 100, 500, 500

End Sub

Private Sub Form_Unload(Cancel As Integer)

'ВНИМАНИЕ ЭТО ВАЖНО

' НЕОБХОДИМО ОСТАНОВИТЬ САБКЛАССИНГ

Unhook

End Sub

--------------

-=Код модуля=-

--------------

Option Explicit

Private Const GWL_WNDPROC = -4

Private Const WM_GETMINMAXINFO = &H24

Private Type POINTAPI

x As Long

y As Long

End Type

Private Type MINMAXINFO

ptReserved As POINTAPI

ptMaxSize As POINTAPI

ptMaxPosition As POINTAPI

ptMinTrackSize As POINTAPI

ptMaxTrackSize As POINTAPI

End Type

Dim lpPrevWndProc As Long

Dim gHW As Long

Private Type Resize

xMin As Single

yMin As Single

xMax As Single

yMax As Single

End Type

Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Sub CopyMemoryToMinMaxInfo Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As MINMAXINFO, ByVal hpvSource As Long, ByVal cbCopy As Long)

Private Declare Sub CopyMemoryFromMinMaxInfo Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As MINMAXINFO, ByVal cbCopy As Long)

Dim rResize As Resize

Public Sub Hook(ByVal wHWND As Long, Optional ByVal X_Min As Single = 0, Optional ByVal Y_Min As Single = 0, Optional ByVal X_Max As Single = 0, Optional ByVal Y_Max As Single = 0)

'Стартуем сабклассинг

gHW = wHWND 'запомним хэндл, чтобы воспользоваться им при остановке классинга

rResize.xMax = X_Max

rResize.yMax = Y_Max

rResize.xMin = X_Min

rResize.yMin = Y_Min

lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)

End Sub

Public Sub Unhook()

Dim temp As Long

'Останавливаем сабклассинг

temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)

End Sub

Private Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim MinMax As MINMAXINFO

'Проверка, ресайзим ли мы окно

If uMsg = WM_GETMINMAXINFO Then

'Необходимо для заголовка child MDI окна (когда развернуто на весь экран)

WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)

'получаем заданные по умолчанию параметры настройки Минимакса

CopyMemoryToMinMaxInfo MinMax, lParam, Len(MinMax)

'Определяем новый минимальный размер окна

'Если не присвоить какое-либо значение в MinMax.ptMinTrackSize.x(y), то

'При ресайзе это значение будет игнорироваться. Тоже самое и для максимальног значения

If rResize.xMin <> 0 Then MinMax.ptMinTrackSize.x = rResize.xMin

If rResize.yMin <> 0 Then MinMax.ptMinTrackSize.y = rResize.yMin

'Определяем новый максимальный размер окна

If rResize.xMax <> 0 Then MinMax.ptMaxTrackSize.x = rResize.xMax

If rResize.yMax <> 0 Then MinMax.ptMaxTrackSize.y = rResize.yMax

'Копируем нашу структуру обратно

CopyMemoryFromMinMaxInfo lParam, MinMax, Len(MinMax)

WindowProc = DefWindowProc(hw, uMsg, wParam, lParam)

Else

WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)

End If

End Function

-------------------

---Bitmap Menu 1---

-------------------

--------------------------------

Имя формы: frmOwnMnu

7 эл-тов PictureBox с картинками

Меню:

Menu1-> Menu2->

1 1

2 2

3 ---

--- 3

4

-=Код формы=-

--------------------------------

Option Explicit

Private Sub DrawNewMenus()

mnuHeight = 24

mnuPicWidth = 24

mnuEdgeWidth = 2

mnuTextBuffer = 8

Dim hMainMenu As Long, hSubMenu As Long

hMainMenu = GetMenu(Me.hwnd)

hSubMenu = GetSubMenu(hMainMenu, 0)

RegisterMenu hSubMenu, 0, Me.hwnd, "Open", Picture1

RegisterMenu hSubMenu, 1, Me.hwnd, "Save", Picture2

RegisterMenu hSubMenu, 2, Me.hwnd, "Print", Picture3

RegisterMenu hSubMenu, 4, Me.hwnd, "Exit", Picture4

hSubMenu = GetSubMenu(hMainMenu, 1)

RegisterMenu hSubMenu, 0, Me.hwnd, "Copy", Picture5

RegisterMenu hSubMenu, 1, Me.hwnd, "Cut", Picture6

RegisterMenu hSubMenu, 3, Me.hwnd, "Paste", Picture7

End Sub

Private Sub Form_Load()

Label1 = "Important!" & vbCrLf & "This sample includes subclassing. Don't close this window from IDE! Use [x] button on form or Exit from menu"

DrawNewMenus

SetSubclass Me

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

FreeMenus

Set frmMenuTest = Nothing

End Sub

Private Sub mnuExit_Click()

Unload Me

End Sub

Private Sub mnuOpen_Click()

MsgBox "Open File Function here", vbInformation

End Sub

Private Sub mnuPrint_Click()

MsgBox "Print File Function here", vbInformation

End Sub

Private Sub mnuSave_Click()

MsgBox "Save File Function here", vbInformation

End Sub

--------------

-=Код модуля=-

--------------

Option Explicit

Private MenuList() As TMenu

Private MenuListCount As Long

Private mnuInitialized As Boolean

Private OldProc As Long ' for subclassing

'API Functions

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long,

Ответить

1. Я подключал эти коды к уже готовой программе

2. Работаю под OS WinME

Ответить

Ответить