Тема: Поменять тип курсора
Кто-нибудь знает как можно поменять курсор во време выполнения команды, используя VBA или Lisp? Спасибо.
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Поменять тип курсора
Форумы CADUser → Программирование → VBA → Поменять тип курсора
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Сообщения 8
- SmeL
- Активный участник
Re: Поменять тип курсора
MousePointer = 0
MousePointer = ...
MousePointer = 15
MousePointer = 99 заменить на свой курсор
Если этого не хватит то привиду пример API
- Vlad
- Восстановленный участник
Re: Поменять тип курсора
Я имею в виду заменить курсор, когда управление передано ACADу, т.е. заменить стандартный ACADовский крестик на поле чертежа (не на форме приложения). Например после
ThisDrawing.Utility.GetPoint(, "Specify insertion point:")
я хочу видеть свой курсор.
У меня что-то не выходит. Спасибо
- SmeL
- Активный участник
Re: Поменять тип курсора
Вот обещаный пример.
Private Declare Function GetWindowsDirectory Lib "kernel32" _
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) _
As Long
Private Declare Function LoadCursorFromFile Lib "user32" _
Alias "LoadCursorFromFileA" (ByVal lpFileName As String) _
As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) _
As Long
Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, _
ByVal id As Long) _
As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private lastcurs As Long
Private newhcurs As Long
Private Const OCR_NORMAL As Long = 32512
Private currenthcurs As Long
Private Sub Command1_Click()
Dim myDir As String
Dim lDir As Long
myDir = Space(255)
currenthcurs = GetCursor()
lastcurs = CopyIcon(currenthcurs)
lDir = GetWindowsDirectory(myDir, 255)
myDir = Left$(myDir, lDir) & "\cursors\dinosau2.ani"
newhcurs = LoadCursorFromFile(myDir)
Call SetSystemCursor(newhcurs, OCR_NORMAL)
End Sub
Private Sub Command2_Click()
Call SetSystemCursor(lastcurs, OCR_NORMAL) [i]'вот это обязательно, чтоб динозаврик не мозолил глаза[/i]
End Sub- Vlad
- Восстановленный участник
Re: Поменять тип курсора
Нет, не работает. Всеравно спасибо.
- Александр Ривилис
- Активный участник
Re: Поменять тип курсора
> Vlad
Это должен быть хук, который устанавливает свой курсор при каждом WM_MOUSEMOVE.
- SmeL
- Активный участник
Re: Поменять тип курсора
> Vlad
Что значит не работает если я тестил на 2000i не думаю, что функционал вашей версии меньше моей.
Данный листинг назначает стандартному курсору новый курсор и сбрасывает его не предидущий. Результатом будет, то что курсор сменится в системе не зависимо от приложения.
> Александр Ривилис
Вроде автор хочет заменить не стандартную стрелочку курсор системы, а внутренний курсор акада крестик.
---
Не знаю как ведет себя мой динозаврик внутри окна ACADа возможно превращается в крестик, протестить не могу выходные дни. А про крестик думаю сменить не составит труда если изменить его в ресурсах :).
---
Вот еще один пример по смене иконки уже не системной пример не тестил, так как пока негде, опробуйте сами, пример неудобен тем, что иконка описывается массивом.
Private Declare Function CreateCursor Lib "user32" (ByVal hInstance As Long, _
ByVal nXhotspot As Long, _
ByVal nYhotspot As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
lpANDbitPlane As Any, _
lpXORbitPlane As Any) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Command1_Click()
Dim hnewcursor As Long ' newly created cursor
Dim holdcursor As Long ' receives handle of default cursor
Dim andbuffer As String, xorbuffer As String ' buffers for masks
Dim andbits(0 To 127) As Byte ' stores the AND mask
Dim xorbits(0 To 127) As Byte ' stores the XOR mask
Dim c As Integer, retval As Long ' counter and return value
andbuffer = "FFFC3FFF" & "FFC01FFF" & "FF003FFF" & "FE00FFFF" & _
"F701FFFF" & "F003FFFF" & "F003FFFF" & "E007FFFF" & _
"C007FFFF" & "C00FFFFF" & "800FFFFF" & "800FFFFF" & _
"8007FFFF" & "8007FFFF" & "0003FFFF" & "0000FFFF" & _
"00007FFF" & "00001FFF" & "00000FFF" & "80000FFF" & _
"800007FF" & "800007FF" & "C00007FF" & "C0000FFF" & _
"E0000FFF" & "F0001FFF" & "F0001FFF" & "F8003FFF" & _
"FE007FFF" & "FF00FFFF" & "FFC3FFFF" & "FFFFFFFF"
xorbuffer = "00000000" & "0003C000" & "003F0000" & "00FE0000" & _
"0EFC0000" & "07F80000" & "07F80000" & "0FF00000" & _
"1FF00000" & "1FE00000" & "3FE00000" & "3FE00000" & _
"3FF00000" & "7FF00000" & "7FF80000" & "7FFC0000" & _
"7FFF0000" & "7FFF8000" & "7FFFE000" & "3FFFE000" & _
"3FC7F000" & "3F83F000" & "1F83F000" & "1F83E000" & _
"0FC7E000" & "07FFC000" & "07FFC000" & "01FF8000" & _
"00FF0000" & "003C0000" & "00000000" & "00000000"
For c = 0 To 127
andbits(c) = Val("&H" & Mid(andbuffer, 2 * c + 1, 2))
xorbits(c) = Val("&H" & Mid(xorbuffer, 2 * c + 1, 2))
Next c
hnewcursor = CreateCursor(App.hInstance, 19, 2, 32, 32, andbits(0), xorbits(0))
holdcursor = SetCursor(hnewcursor) ' change cursor
Sleep 10000 'Wait 10 seconds
retval = SetCursor(holdcursor) ' change cursor back
retval = DestroyCursor(hnewcursor)
End Sub
- Fatty
- Восстановленный участник
Re: Поменять тип курсора
> SmeL
Я в восторге, работает как часы, только
для чистого VBA заменить строчку:
hnewcursor = CreateCursor(App.hInstance, 19, 2, 32, 32, andbits(0), xorbits(0))
на следующую
hnewcursor = CreateCursor(0&, 19, 2, 32, 32, andbits(0), xorbits(0))
Андрей, ты молодца :)
~'J'~
Сообщения 8
Тему читают: 1 гость
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → Поменять тип курсора
Форум работает на PunBB, при поддержке Informer Technologies, Inc
