Buenas, tengo un pequeño problema con una aplicacion que no me carga un cursor, debido a esto me vi obligado a usar varias APIs para cargar el cursor. En si la aplicacion si cargo el cursor correctamente pero solo hasta que se mueve el mouse luego de eso regresa al anterior :S.
La idea es cargar el cursor en la aplicacion y cuando esta cierre que el cursor quede como estaba.
Aca les dejo el code que encontre pero es el que cambia al mover el cursor:
Private Declare Function LoadCursorFromFile Lib "user32.dll" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32.dll" (ByVal hCursor As Long) As Long
' Display the application starting (arrow and hourglass) Windows
' cursor for three seconds. The cursor resource is loaded from Windows. Then
' restore the old cursor (whatever it happens to be).
Dim hcursor As Long ' receives handle to application starting cursor
Dim holdcursor As Long ' receives handle to previously used cursor
Dim retval As Long ' throw-away return value
hcursor = LoadCursor(0, IDC_APPSTARTING) ' load Windows's application starting cursor
holdcursor = SetCursor(hcursor) ' set it to the new cursor
Sleep 3000 ' wait for 3 seconds
retval = SetCursor(holdcursor) ' set it to the previous cursor
NOTA: Intente cambiando el cursor actual con SetSystemCursor pero no creo que eso sea buena idea ya que despues hay que restaurar el cursor de forma manual :S.
No uses Sleep, usa doevents, BlackZeroX tiene una funcion que te puede ayudar
Si lo intente con DoEvents pero inmediatamente despues de cambiar el cursor vuelve al anterior :S
HOLA!!!
Intentaste no usar el cursor, usa un shape o form o picturebox o lo que sea que persiga al mouse, entonces tenes un mouse "visible".
GRACIAS POR LEER!!!
Cita de: DarkMatrix en 21 Diciembre 2010, 18:04 PM
Si lo intente con DoEvents pero inmediatamente despues de cambiar el cursor vuelve al anterior :S
Esporque tenes que hacer doevents mediante 3 segundos, con algun bucle o algo :P
Cita de: raul338 en 21 Diciembre 2010, 18:24 PM
Esporque tenes que hacer doevents mediante 3 segundos, con algun bucle o algo :P
:¬¬ Entonces porque no usar Sleep() :huh:
Aun asi, la cosa seria como esto:
Sub Wait(lMs as long)
dim lTimer as long
lTimer = Timer()
do
DoEvents
loop while (Timer() - lTimer < lMs)
end sub
Karcrack, porque el sleep congela todo :xD
Creo que no me entendieron mucho de que se trata :S, bueno aqui subi un projecto de ejemplo: http://www.megaupload.com/?d=T0HXO5OF
Ok el codigo es este:
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function LoadCursorFromFile Lib "user32.dll" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32.dll" (ByVal hCursor As Long) As Long
Private Sub Form_Load()
Dim hCursor As Long
Dim holdcursor As Long
Dim retval As Long
hCursor = LoadCursorFromFile(App.Path & "\AB1.cur")
If hCursor = 0 Then End
holdcursor = SetCursor(hCursor)
Sleep 3000 ' Mientras la aplicacion se encuentra pausada el cursor se mantiene
retval = SetCursor(holdcursor) ' si se anula esta linea para no restaurar el cursor anterior, igual vuelve a como estaba antes :S.
End Sub
Lo que quiero lograr es que el cursor se mantenga hasta finalizar la aplicacion o llamar a la funcion para restaurarlo. Alguna idea del porque el cursor vuelve a como estaba?
Option Explicit
Private Declare Function SetCursor Lib "user32.dll" (ByVal hcursor As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Const IDC_APPSTARTING As Long = 32650
Private Const IDC_ARROW As Long = 32512&
Private Declare Function LoadCursor Lib "user32.dll" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Dim normal As Long, wait As Long
Private Sub Form_Load()
wait = LoadCursor(0&, IDC_APPSTARTING)
normal = LoadCursor(0&, IDC_ARROW)
Esperar 3000
Call SetCursor(normal) ' set it to the previous cursor
End Sub
Public Sub Esperar(Miliseconds As Long)
Dim retraso As Long
'GetTickCount devuelve un valor inicial, y se lo sumamos al de retraso
retraso = Miliseconds + GetTickCount
While retraso >= GetTickCount
DoEvents
Call SetCursor(wait)
Wend
End Sub
El problema fue que apenas se ponia el cursor, se cambiaba el cursor a otro segun el evento de una ventana :P por eso en ese bucle, forzamos a mostrar nuestro cursor :P
¿Lo que buscas no es esto? :huh:
Option Explicit
Private Declare Function LoadCursorFromFile Lib "user32.dll" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32.dll" (ByVal hCursor As Long) As Long
Private hOldCursor As Long
Private bStop As Boolean
Private Sub Form_Load()
Dim hCursor As Long
hCursor = LoadCursorFromFile("c:\bullseye.cur")
If hCursor = 0 Then End
Me.Show: DoEvents
Do While bStop = False
hOldCursor = SetCursor(hCursor)
DoEvents
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
bStop = True
Call SetCursor(hOldCursor)
End Sub
DoEvents! :P
Mr. Frog © estas en lo correcto algo asi es lo que necesito, pero hay un problema, ya habia intentado algo asi y resulta que en la aplicacion en la que quiero implementar la funcion para cambiar el mouse ya tiene un sub que entra en un bucle y por lo tanto uno de los dos bucles no se ejecutara :S, Alguna otra idea?
Mezcla los 2 eventos :P Que tipo de bucle es ?
Lo haria pero pasa que si se mezclan entonces el mouse no se redibuja con la frecuencia suficiente como para simular que el cursor no cambia :S, Es un bucle encargado de pintar en un picturebox el cual siempre se esta ejecutando.
Entonces tienes un problema de repintado, tienes que optimizar el bucle ._.
.
@DarkMatrix
si es para el juego de YuGioh que traes mejor resignate a pasarlo a un motor grafico como DirectX u OpenGL asi no tendras que gastar el procesador en vano.
Funcion Wait (No consume procesador) (http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=6:artwait&catid=2:catprocmanager&Itemid=8)
Tome el ejemplo de la API Guide, saque todas las variable por que no queria estar revisando cuales eran las que se requerian asi que aqui tienes, no se come el proesador, y no para el hilo de tu programa.
'
' /////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandecido //
' // o achicado, si es en base a este codigo //
' /////////////////////////////////////////////////////////////
' // http://infrangelux.sytes.net/Blog/index.php?option=com_content&view=article&id=6:artwait&catid=2:catprocmanager&Itemid=8
' /////////////////////////////////////////////////////////////
Option Explicit
Private Declare Function WaitMessage Lib "user32" () As Long
Enum eTime
Horas = 3600
Minutos = 60
Segundos = 1
End Enum
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)
Dim hnewcursor As Long ' newly created cursor
Dim holdcursor As Long ' receives handle of default cursor
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
' Create a 32x32 color cursor shaped somewhat like a yin-yang symbol.
' (The bit masks come from Microsoft's documentation on the API cursors function, just to
' give them their due credit.) Note how the masks are loaded into the arrays. The new
' cursor is then set to be the cursor for 10 seconds.
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
' Unfortunately, VB does not provide a nice way to load lots of information into an array.
' To load the AND and XOR masks, we put the raw hex values into the string buffers
' and use a loop to convert the hex values into numeric values and load them into
' the elements of the array. Yes, it's ugly, but there's no better way. Note the
' use of the line-continuation character here. Each sequence of eight hex
' characters represents one line in the 32x32 cursor.
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"
' Now load these hex values into the proper arrays.
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
' Finally, create this cursor! The hotspot is at (19,2) on the cursor.
hnewcursor = CreateCursor(App.hInstance, 19, 2, 32, 32, andbits(0), xorbits(0))
' Set the new cursor as the current cursor for 10 seconds and then switch back.
wait 10000, Horas 'Wait 10000 horas jeje haber que pc aguanta esto encendida...
retval = SetCursor(holdcursor) ' change cursor back
' Destroy the new cursor.
retval = DestroyCursor(hnewcursor)
End Sub
Public Sub wait(ByVal vToWait&, Optional ByVal ThisWait As eTime = Segundos, Optional ByVal UseAllProc As Boolean = False)
Dim vDateE As Date
vDateE = DateAdd("s", vToWait& * (ThisWait + 0), Time)
Do While vDateE > Time
holdcursor = SetCursor(hnewcursor) ' change cursor
Call WaitMessage
If Not UseAllProc Then DoEvents
Loop
End Sub
P.D.: Adapta el codigo y metelo a un modulo de clase y donde puse holdcursor = SetCursor(hnewcursor) ' change cursor puedes meter un RaiseEvent... solo para notificar por mensajes entrantes asi se puede malear el proceso Wait()...
Temibles Lunas!¡.