| Вопрос: Вызов Календаря и отбор выбранного значения | Добавлено: 31.07.12 22:33 |
Автор вопроса:  Millenium | Web-сайт: www.aliyev.us | ICQ: 629966 |
|
Здравствуйте!
Создаю через APİ CreateWindowEx календарь. Всё создаётся ОК. Но как получить выбранное значение? Код привел ниже. Option Explicit
Private Const WS_CHILD As Long = &H40000000 Private Const WS_VISIBLE As Long = &H10000000 Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" ( _ ByVal dwExStyle As Long, _ ByVal lpClassName As String, _ ByVal lpWindowName As String, _ ByVal dwStyle As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hWndParent As Long, _ ByVal hMenu As Long, _ ByVal hInstance As Long, _ ByRef lpParam As Any) As Long Private Sub Form_Load() Call CreateWindowEx(0, "SysDateTimePick32", vbNullString, _ WS_CHILD + WS_VISIBLE, 8, 16, 90, 22, Frame1.hWnd, 0, App.hInstance, Null) Call CreateWindowEx(1, "SysMonthCal32", vbNullString, _ WS_CHILD + WS_VISIBLE, 200, 30, 190, 165, Me.hWnd, 0, App.hInstance, Null) End Sub Как в нажатием на кнопку или по клику на календарь передать значение в другой элемент или получить выбранное значение календаря? Буду благодарен быстрому ответу. |
| Ответы | Всего ответов: 20 |
|
Номер ответа: 1 Автор ответа: Millenium ICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #1 | Добавлено: 01.08.12 00:17 |
И есчё вот что. Во время выполнения приложения в самом ВБ всё отображается, а вот после компиляции, календарь не виден 
|
||
|
Номер ответа: 2 Автор ответа:  Cramper Вопросов: 15 Ответов: 93 |
Профиль | Цитата | #2 | Добавлено: 01.08.12 08:12 |
| Почему не воспользоваться стандартным контролом? | ||
|
Номер ответа: 3 Автор ответа: AvvelanaВопросов: 2 Ответов: 18 |
Профиль | Цитата | #3 | Добавлено: 01.08.12 13:13 |
|
Думаю придётся извращаться с WinApi.
Начнём с переменных: Public MainProcAddr As Long 'Адрес главной оконной процедуры. Public DtpProcAddr As Long 'Текущий адрес оконной процедуры ДэйтТаймПикера. Public McProcAddr As Long 'Текущий адрес оконной процедуры Календаря. Public DtpHwnd As Long 'Идентификатор ДэйтТаймПикера. Public McHwnd As Long 'Идентификатор Календаря. Public FuncProc As Long 'Адрес новой оконной процедуры, в которой мы будем отлавливать сообщения. Нам нужна процедура, в которой будем отлавливать сообщения: Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long ... End Function Создаём окна и получаем данные: Dim res As Long 'Результат операции DtpHwnd = CreateWindowEx(0, "SysDateTimePick32", vbNullString, _ 'Создаём ДэйтТаймПикер и получаем его hWnd WS_CHILD + WS_VISIBLE, 8, 16, 90, 22, Frame1.hwnd, 0, App.hInstance, Null) McHwnd = CreateWindowEx(1, "SysMonthCal32", vbNullString, _ 'Создаём Календарь и получаем его hWnd WS_CHILD + WS_VISIBLE, 200, 30, 190, 165, Me.hwnd, 0, App.hInstance, Null) DtpProcAddr = GetWindowLong(DtpHwnd, GWL_WNDPROC) 'Получаем текущий адрес оконной процедуры ДэйтТаймПикера McProcAddr = GetWindowLong(McHwnd, GWL_WNDPROC) 'Получаем текущий адрес оконной процедуры Кадендаря MainProcAddr = GetWindowLong(Form1.hwnd, GWL_WNDPROC) 'Получаем текущий адрес оконной процедуры главного окна (будет необходим далее) res = SetWindowLong(DtpHwnd, GWL_WNDPROC, AddressOf WindowProc) 'Назначаем новый адрес оконной процедуры ДэйтТаймПикера (AddressOf WindowProc) res = SetWindowLong(McHwnd, GWL_WNDPROC, AddressOf WindowProc) 'Назначаем новый адрес оконной процедуры Календаря (AddressOf WindowProc) Можно добавить обработчик ошибок, но для примера он не нужен. Далее код оконной процедуры WindowProc: Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long Dim pid As Long 'Ид процесса Dim hp As Long 'Хендл процесса Dim res As Long 'Результат Select Case wMsg 'Блок выбора WM сообщений Case WM_NOTIFY If hwnd = DtpHwnd Then 'Если сообщение пришло от Дейтпикера pid = GetCurrentProcessId() 'получаем ИД нашего процесса hp = OpenProcess(PROCESS_VM, 0&, pid) 'получаем хендл нашего процесса res = ReadProcessMemory(hp, lParam, VarPtr(DTC), 32, 0&  'Читаем память (Других способов перебросить структуру из lParam не знаю)
res = CloseHandle(hp) 'Закрываем процесс Call CallWindowProc(MainProcAddr, Form1.hwnd, wMsg, wParam, lParam) ' Переназначаем главному окну процедуру по умолчанию. (Если не сделать этого - перестанет работать эта процедура и окна Дейтпикера и календаря не будут обновляться и получать сообщения.) If DTC.dwFlags = -746 Then 'Вообще-то есть нормальный способ определять какой код мы получили, но для этого нужно глубже вникать в типы. Form1.Label1.Caption = "Выбрана дата: " & DTC.st.wDay & " / " & DTC.st.wMonth & " / " & DTC.st.wYear & " (Дейтпикер)" End If End If End Select If hwnd = DtpHwnd Then 'Если дейтпикер прислал сообщение - назначаем ему стандартную оконную процедуру и отдаём управление винде. WindowProc = CallWindowProc(DtpProcAddr, hwnd, wMsg, wParam, lParam) Else 'Если нет - назначаем календарю стандартную оконную процедуру и отдаём управление винде. WindowProc = CallWindowProc(McProcAddr, hwnd, wMsg, wParam, lParam) End If End Function С Календарём не стал возиться, всё тоже самое, единственное отличие от дэйтпикера в том, что вместо NMDATETIMECHANGE нужно использвоать NMSELCHANGE. Весь код полностью: Код формы: Private Sub Command1_Click() ShowDTP End Sub Sub ShowDTP() Dim res As Long  tpHwnd = CreateWindowEx(0, "SysDateTimePick32", vbNullString, _
WS_CHILD + WS_VISIBLE, 8, 16, 90, 22, Frame1.hwnd, 0, App.hInstance, Null) McHwnd = CreateWindowEx(1, "SysMonthCal32", vbNullString, _ WS_CHILD + WS_VISIBLE, 200, 30, 190, 165, Me.hwnd, 0, App.hInstance, Null) tpProcAddr = GetWindowLong(DtpHwnd, GWL_WNDPROC)
McProcAddr = GetWindowLong(McHwnd, GWL_WNDPROC) MainProcAddr = GetWindowLong(Form1.hwnd, GWL_WNDPROC) res = SetWindowLong(DtpHwnd, GWL_WNDPROC, AddressOf WindowProc) res = SetWindowLong(McHwnd, GWL_WNDPROC, AddressOf WindowProc) End Sub Код модуля: [CODE] Option Explicit Public Const WS_CHILD As Long = &H40000000 Public Const WS_VISIBLE As Long = &H10000000 Public Const GWL_WNDPROC = -4 Public Const PROCESS_VM_READ = &H10 Public Const PROCESS_VM_WRITE = &H20 Public Const PROCESS_VM_OPERATION = &H8 Public Const PROCESS_VM = PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE Public Const WM_NOTIFY = 78 Public Const WM_COMMAND = 273 Public Const WM_LBUTTONDOWN = 513 Public Const ICC_DATE_CLASSES = 256 Public Type NMHDR hwndFrom As Integer idFrom As Integer code As Integer End Type Public Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Public Type NMDATETIMECHANGE NMHDR As NMHDR dwFlags As Long st As SYSTEMTIME End Type Public Type NMSELCHANGE NMHDR As NMHDR stSelStart As SYSTEMTIME stSelEnd As SYSTEMTIME End Type Public DTC As NMDATETIMECHANGE Public NMC As NMSELCHANGE Public Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" ( _ ByVal dwExStyle As Long, _ ByVal lpClassName As String, _ ByVal lpWindowName As String, _ ByVal dwStyle As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hWndParent As Long, _ ByVal hMenu As Long, _ ByVal hInstance As Long, _ ByRef lpParam As Any) As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public 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 Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByVal lpBuffer As Long, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Public MainProcAddr As Long Public DtpProcAddr As Long Public McProcAddr As Long Public DtpHwnd As Long Public McHwnd As Long Public FuncProc As Long Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long Dim pid As Long Dim hp As Long Dim res As Long Select Case wMsg Case WM_NOTIFY If hwnd = DtpHwnd Then pid = GetCurrentProcessId() hp = OpenProcess(PROCESS_VM, 0&, pid) res = ReadProcessMemory(hp, lParam, VarPtr(DTC), 32, 0&) res = CloseHandle(hp) Call CallWindowProc(MainProcAddr, Form1.hwnd, wMsg, wParam, lParam) If DTC.dwFlags = -746 Then Form1.Label1.Caption = "Óêàçàíà äàòà: " & DTC.st.wDay & " / " & DTC.st.wMonth & " / " & DTC.st.wYear & " (Äýéòïèêåð)" End If End If End Select If hwnd = DtpHwnd Then WindowProc = CallWindowProc(DtpProcAddr, hwnd, wMsg, wParam, lParam) Else WindowProc = CallWindowProc(McProcAddr, hwnd, wMsg, wParam, lParam) End If End Function |
||
|
Номер ответа: 4 Автор ответа: AvvelanaВопросов: 2 Ответов: 18 |
Профиль | Цитата | #4 | Добавлено: 01.08.12 13:21 |
| Прошу прощения, не вставил конечный тег. | ||
|
Номер ответа: 5 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #5 | Добавлено: 02.08.12 20:02 |
|
Спасибо! После пары сиправлений всё заработало.
Но вот как получить выбранное значение календаря? Интересует только: SysMonthCal32 |
||
|
Номер ответа: 6 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #6 | Добавлено: 03.08.12 10:40 |
| Значение не возвращается лейблу. Никак. | ||
|
Номер ответа: 7 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #7 | Добавлено: 03.08.12 10:42 |
| http://www.xlplus.de/vbaCorner/DateTimePicker/cMonthCtrl.asp - Вот ресурс. Там тоже самое у меня получатся. Почему сам пичкер не ставлю, потому что библиотеки приходится таскать. | ||
|
Номер ответа: 8 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #8 | Добавлено: 03.08.12 10:44 |
| http://us.generation-nt.com/sysdatetimepick32-help-9633902.html - тоже с этой-же проблемой столкнулся. | ||
|
Номер ответа: 9 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #9 | Добавлено: 03.08.12 21:52 |
| Avvelana АУ! | ||
|
Номер ответа: 10 Автор ответа: AvvelanaВопросов: 2 Ответов: 18 |
Профиль | Цитата | #10 | Добавлено: 04.08.12 13:55 |
|
Прошу прощения, редко бываю тут. Действительно, с календарём не работает, какой-то мусор копируется. Ну это объяснить можно тем, что всё-таки типы данных разные, я примерно подогнал в соответствии с логикой. Нужно глубже смотреть, попробую вечерком поэкспериментировать.
Там вся суть в том, что-бы поймать код MCN_SELECT, который передаётся в сообщении как lParam в сообщении WM_NOTIFY. Кстати, как показал беглый анализ, WM_NOTIFY на календарь почему-то не приходит если сделать как в примере выше. Точнее приходит, но не при клике на дату, а при изменении года. В lParam какая-то каша. Не знаю даже, нужно посмотреть, вечерком сегодня посмотрю. |
||
|
Номер ответа: 11 Автор ответа: AvvelanaВопросов: 2 Ответов: 18 |
Профиль | Цитата | #11 | Добавлено: 04.08.12 14:15 |
| Для тебя критично реализовать на чистом Апи без дополнительных ДЛЛ? Может написать тебе библиотеку размером ~25кб на C с парой вызовов? Просто что-то мне эти танцы с копирование памяти в сомнительные массивы совсем не нравятся.. | ||
|
Номер ответа: 12 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #12 | Добавлено: 05.08.12 21:43 |
|
Да. Критично. Сейчас пока воспользовался 3-я ListBox-ами. Но вот проверять например февраль, 29 и прочее тошно и долго. А при использование календаря, нереальную дату не выберишь.
Плюсь мне приходится есчё сверить файлы по дате. Без календаря будет мура. И память ограничена, и работает почти под ДОС. Нада минимум сторонних копмпонентов. |
||
|
Номер ответа: 13 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #13 | Добавлено: 05.08.12 22:30 |
| А не трудно будет написать Вам на Си для меня ДЛЛ? | ||
|
Номер ответа: 14 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #14 | Добавлено: 07.08.12 09:57 |
|
It's friggin scary, just looking at Jeremy's code. To give you a hint, when he
sinks WM_SETFOCUS for the created window, he calls this routine: Private Sub HandleWMSETFOCUS() Dim pOleObject As IOleObject Dim pOleInPlaceSite As IOleInPlaceSite Dim pOleInPlaceFrame As IOleInPlaceFrame Dim pOleInPlaceUIWindow As IOleInPlaceUIWindow Dim pOleInPlaceActiveObject As IOleInPlaceActiveObject Dim PosRect As Rect Dim ClipRect As Rect Dim FrameInfo As OLEINPLACEFRAMEINFO 'Get in-place frame and make sure it is set to our in-between 'implementation of IOleInPlaceActiveObject in order to catch 'TranslateAccelerator calls Set pOleObject = m_UserControl Set pOleInPlaceSite = pOleObject.GetClientSite pOleInPlaceSite.GetWindowContext pOleInPlaceFrame, pOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo) CopyMemory pOleInPlaceActiveObject, m_IPAOHookStruct.ThisPointer, 4 pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString CopyMemory pOleInPlaceActiveObject, 0&, 4 End Sub There's just this inherent conflict between the UC window and it's contained window, it appears. I see he's also calling SetFocus (the API) to the UC when the contained control gets a WM_MOUSEACTIVATE message. |
||
|
Номер ответа: 15 Автор ответа: MilleniumICQ: 629966 Вопросов: 118 Ответов: 903 |
Web-сайт: Профиль | Цитата | #15 | Добавлено: 07.08.12 09:59 |
| ДЛЛ-ку добавить не получится. Потому что среда куда будет вьита программа только модет взять одно приложение. Т.е. по сути я щаменяб то что до меня было написанр. А среду не могу. Доступ только к m2ttkRRep.exe (это то что я буду перехаписывать). Темболее у меня маск 700кб пустого пространства. | ||