Temas

[No se trata de un código optimizado]

Hola, para el q le interese el Mensaje WM_NCHITTEST puede detectar en que lugar de una ventana o control está pasando el puntero del mouse o combinado con un hook al mouse tambien se puede saber donde se está haciendo un click (entre otras cosas)... Abarca el area-cliente, botones de cerrar, maximizar y minimizar, barra de titulo, icono de la barra, bordes derecho, izquierdo, angulos, bordes bixed, etc.

No se trata de un código optimizado, solo un simple concepto para el q no la conoce, saludos

Form

Código (vb) [Seleccionar] Expandir




Option Explicit

Private Sub Form_Load()
Call SetWindowPos(Me.hwnd, &HFFFF, &H0, &H0, &H0, &H0, &H2 Or &H1) 'on top (opcional)
Call StartHook
End Sub
Private Sub Form_Unload(Cancel As Integer)
 StopHook
End Sub






Module

Código (vb) [Seleccionar] Expandir




Option Explicit

'Modulo: NCHITTEST
'Autor   : Sergio Desanti (Hasseds)
'Test    : XP (32 BIT)


Public 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.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Type POINTAPI: x As Long: y As Long: End Type
Private Const WM_NCHITTEST = &H84

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Dim hHook As Long

Function Make_lParam(ByVal x As Integer, ByVal y As Integer) As Long
 Make_lParam = x Or (y * &H10000)
End Function

Public Sub StartHook()
    hHook = SetWindowsHookEx(&HE, AddressOf MouseProc, App.hInstance, &H0)
End Sub

Public Sub StopHook()
   Call UnhookWindowsHookEx(hHook)
   hHook = 0
End Sub

Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, lParam As POINTAPI) As Long

 Dim hwndl As Long
 hwndl = WindowFromPoint(lParam.x, lParam.y)
 
 Dim retNCHITTEST As Long
 retNCHITTEST = SendMessage(hwndl, WM_NCHITTEST, &H0&, ByVal Make_lParam(lParam.x, lParam.y))
 

 'If wParam = &H201 Then
   If hwndl = Form1.hwnd Then
     Select Case retNCHITTEST
       Case 1:  Form1.Caption = "AREA CLIENTE"
       Case 2:  Form1.Caption = "BARRA DE TITULO"
       Case 3:  Form1.Caption = "ICONO LA BARRA DE TITULO"
       Case 6:  Form1.Caption = "SCROLL HORIZONTAL"
       Case 7:  Form1.Caption = "SCROLL VERTICAL"
       Case 8:  Form1.Caption = "BOTON MINIMIZAR"
       Case 9:  Form1.Caption = "BOTON MAXIMIZAR"
       Case 10: Form1.Caption = "BORDE IZQUIERDO"
       Case 11: Form1.Caption = "BORDE DERECHO"
       Case 12: Form1.Caption = "BORDE SUPERIOR"
       Case 13: Form1.Caption = "BORDE SUPERIOR IZQUIERDO"
       Case 14: Form1.Caption = "BORDE SUPERIOR DERECHO"
       Case 15: Form1.Caption = "BORDE INFERIOR"
       Case 16: Form1.Caption = "BORDE INFERIOR IZQUIERDO"
       Case 17: Form1.Caption = "BORDE INFERIOR DERECHO"
       Case 18: Form1.Caption = "BORDE FIXED"
       Case 20: Form1.Caption = "BOTON CERRAR"
       Case 21: Form1.Caption = "BOTON AYUDA"
       Case Else: Form1.Caption = retNCHITTEST
     End Select
   Else
     Form1.Caption = "FUERA DE VENTANA"
   End If
 'End If
 
 '.......................................................................
  Dim PT As POINTAPI
  Call ClientToScreen(hwndl, PT)

  Form1.Cls
  Form1.Print "Coordenada Screen X " & lParam.x
  Form1.Print "Coordenada Screen Y " & lParam.y
 
  If hwndl = Form1.hwnd Then
    Form1.Print
    Form1.Print "Coordenada Control X " & lParam.x - PT.x
    Form1.Print "Coordenada Control Y " & lParam.y - PT.y
  End If
 '.......................................................................
 
 MouseProc = CallNextHookEx(hHook, ncode, wParam, lParam)

End Function




Retorno = Seriales de Pen-Drives conectados

Código (vb) [Seleccionar] Expandir



Option Explicit

'Function: FlashSerials
'Autor   : Sergio Desanti (Hasseds)
'Thank   : Seba , Cobein, A.Desanti
'Test    : XP (32 BIT) - W7/UAC (32 BIT)
'Return  : Serial(ESN) de Pen-Drives conectados
'
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As GUID) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByRef ClassGuid As GUID, ByVal Enumerator As Long, ByVal hwndParent As Long, ByVal flags As Long) As Long
Private Declare Function SetupDiEnumDeviceInterfaces Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByRef InterfaceClassGuid As GUID, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Long
Private Declare Function SetupDiGetDeviceInterfaceDetail Lib "setupapi.dll" Alias "SetupDiGetDeviceInterfaceDetailA" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, DeviceInterfaceDetailData As Any, ByVal DeviceInterfaceDetailDataSize As Long, ByRef RequiredSize As Long, DeviceInfoData As Any) As Long
Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long


Private Type GUID
   Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(7) As Byte
End Type

Private Type SP_DEVICE_INTERFACE_DATA
   cbSize As Long: InterfaceClassGuid As GUID: flags As Long: Reserved As Long
End Type

Private Type SP_DEVINFO_DATA
   cbSize As Long: ClassGuid As GUID: DevInst As Long: Reserved As Long
End Type

Private Type SP_DEVICE_INTERFACE_DETAIL_DATA
   cbSize As Long: strDevicePath As String * 260
End Type

Private Sub Form_Load()
    AutoRedraw = True
    Print FlashSerials
End Sub

Public Function FlashSerials() As String

   Dim TGUID As GUID
   
   Call IIDFromString(StrPtr("{a5dcbf10-6530-11d2-901f-00c04fb951ed}"), TGUID)
   
   Dim hDev As Long
   hDev = SetupDiGetClassDevs(TGUID, &H0, &H0, &H12)
   If hDev = -1 Then Exit Function

   Dim lCount        As Long
   Dim lSize         As Long
   Dim DEV_DETAIL    As SP_DEVICE_INTERFACE_DETAIL_DATA
   Dim DEV_INFO      As SP_DEVINFO_DATA
   Dim DEV_DATA      As SP_DEVICE_INTERFACE_DATA
   
   DEV_DATA.cbSize = Len(DEV_DATA)
   
   While SetupDiEnumDeviceInterfaces(hDev, &H0, TGUID, lCount, DEV_DATA) <> &H0
     Call SetupDiGetDeviceInterfaceDetail(hDev, DEV_DATA, ByVal &H0, &H0, lSize, ByVal &H0)
     DEV_DETAIL.cbSize = &H5
     DEV_INFO.cbSize = Len(DEV_INFO)
     Call SetupDiGetDeviceInterfaceDetail(hDev, DEV_DATA, DEV_DETAIL, ByVal lSize, &H0, DEV_INFO)
     If UBound(Split(DEV_DETAIL.strDevicePath, "#")) > 1 Then
       FlashSerials = FlashSerials & Split(UCase$(DEV_DETAIL.strDevicePath), "#")(2) & Chr$(&HD)
     End If
     lCount = lCount + 1
   Wend
   
   Call SetupDiDestroyDeviceInfoList(hDev)

End Function



Código [Seleccionar] Expandir



Option Explicit

'Author: Sergio Desanti
'Proved: XP (32 BIT)

Private Declare Function CreateToolhelp32Snapshot Lib "Kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "Kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "Kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)

Private Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As Long

Private Type PROCESSENTRY32
    dwSize As Long: cntUsage As Long: th32ProcessID As Long: th32DefaultHeapID As Long: th32ModuleID As Long: cntThreads As Long: th32ParentProcessID As Long: pcPriClassBase As Long: dwFlags As Long: szExeFile As String * 260
End Type

Private Sub Form_Load()
   
    Shell "calc"
    Shell "calc"
   
    MsgBox IsWay("caLc.Exe")

End Sub

Private Function IsWay(ByVal NombreDelProceso As String) As String
 
  Dim Handle_Procesos As Long
  Handle_Procesos = CreateToolhelp32Snapshot(&HF, 0&)
 
  Dim PE32 As PROCESSENTRY32
  PE32.dwSize = Len(PE32)

  Dim PidProc   As Long
  Dim NameProc  As String
  Dim RutaProc  As String
 
  Dim ret As Long
  ret = Process32First(Handle_Procesos, PE32)
   
  While ret > 0
   
      NameProc = Split(PE32.szExeFile, Chr$(0))(0)
   
      If LCase$(NameProc) = LCase$(NombreDelProceso) Then
     
          PidProc = PE32.th32ProcessID
     
          Dim H_Proceso As Long
          H_Proceso = OpenProcess(&H410, &H0, PidProc)
   
          Dim Buffer As String * &H104
   
          Call GetModuleFileNameExA(H_Proceso, &H0, Buffer, &H104)
          Call CloseHandle(H_Proceso)
   
          RutaProc = Split(Buffer, Chr$(0))(0)
     
          IsWay = IsWay & vbNewLine & RutaProc & vbTab & PidProc
   
      End If
   
      ret = Process32Next(Handle_Procesos, PE32)
 
  Wend
 
  Call CloseHandle(Handle_Procesos)

  If IsWay = "" Then IsWay = "No esta Corriendo"

End Function




Hay varios codes que hacen lo mismo, pero todos los que encontré usan Hook (me resisto a usarlos)
Solo un Timer1 en el Form

NOTA 1: en el momento que el If del timer1 devuelve el string con la letra de la unidad  detectada ya se puede "operar"

NOTA 2: este code no incluye a los disquetes, ya que el for de la Function UnidadesUSB empiza desde 2 hasta 25 (cero y uno corresponden tambien a unidades extribles pero el sistema los reserva para las disqueteras)

Código [Seleccionar] Expandir


'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Option Explicit ' Hassed (http://foro.elhacker.net/programacion_vb-b50.0/)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Dim ControlUnidadesUSB1 As String: Dim ControlUnidadesUSB2 As String

Private Sub Form_Load()
 Timer1.Interval = 50: Me.AutoRedraw = True: Me.FontBold = True
End Sub

Private Function UnidadesUSB() As String
 Dim DiscosLogicos As Long: DiscosLogicos = GetLogicalDrives: Dim i As Long
 For i = 2 To 25
   If (DiscosLogicos And 2 ^ i) <> 0 Then
     If GetDriveType(Chr$(65 + i) + ":") = 2 Then
       UnidadesUSB = UnidadesUSB + Chr$(65 + i)
     End If
   End If
 Next i
End Function

Private Sub Timer1_Timer()
 ControlUnidadesUSB1 = UnidadesUSB
 If ControlUnidadesUSB1 <> ControlUnidadesUSB2 Then
   If Len(ControlUnidadesUSB1) > Len(ControlUnidadesUSB2) Then
     Dim i As Integer
     For i = 1 To Len(ControlUnidadesUSB1)
       If InStr(ControlUnidadesUSB2, Mid(ControlUnidadesUSB1, i, 1)) = 0 Then Me.Print Mid(ControlUnidadesUSB1, i, 1) + vbTab & Time
     Next i
   End If
   ControlUnidadesUSB2 = UnidadesUSB
 End If
End Sub




NOTA 3: el mismo code pero un poco mas completo

Código [Seleccionar] Expandir


'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Option Explicit ' Hassed (http://foro.elhacker.net/programacion_vb-b50.0/)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Dim ControlUnidadesUSB1 As String: Dim ControlUnidadesUSB2 As String

Private Sub Form_Load()
 If App.PrevInstance = True Then End
 ControlUnidadesUSB2 = "$"
 Me.AutoRedraw = True
 Me.FontBold = True
 Timer1.Interval = 50
End Sub
Private Function UnidadesUSB() As String
 Dim LDs As Long:  LDs = GetLogicalDrives
 Dim Cnt As Long: Dim sDrives As String
 For Cnt = 2 To 25
   If (LDs And 2 ^ Cnt) <> 0 Then
     If GetDriveType(Chr$(65 + Cnt) + ":") = 2 Then
       sDrives = sDrives + Chr$(65 + Cnt)
     End If
   End If
 Next Cnt
 UnidadesUSB = Replace(Replace(sDrives, " ", ""), ":", "")
End Function

Private Sub Timer1_Timer()
 If UnidadesUSB <> "" Then Me.Caption = "Unidades USB: " + UnidadesUSB
 If UnidadesUSB = "" Then Me.Caption = "No hay Unidades USB conectadas"
 ControlUnidadesUSB1 = UnidadesUSB
 If ControlUnidadesUSB1 <> ControlUnidadesUSB2 Then
     Dim i As Integer
     If Len(ControlUnidadesUSB1) > 0 Then
         If Len(ControlUnidadesUSB1) > Len(ControlUnidadesUSB2) Then
             For i = 1 To Len(ControlUnidadesUSB1)
                 If InStr(ControlUnidadesUSB2, Mid(ControlUnidadesUSB1, i, 1)) = 0 Then Me.Print "conexión" + vbTab + Mid(ControlUnidadesUSB1, i, 1) + vbTab & Time
             Next i
             ControlUnidadesUSB2 = UnidadesUSB
         Else
             If ControlUnidadesUSB2 = "$" Then
                 Me.Print "conexión" + vbTab + UnidadesUSB + vbTab & Time
                 ControlUnidadesUSB2 = UnidadesUSB
             Else
                 For i = 1 To Len(ControlUnidadesUSB2)
                     If InStr(ControlUnidadesUSB1, Mid(ControlUnidadesUSB2, i, 1)) = 0 Then Me.Print "EXPULCIÓN" + vbTab + Mid(ControlUnidadesUSB2, i, 1) + vbTab & Time
                 Next i
                 ControlUnidadesUSB2 = UnidadesUSB
             End If
         End If
     Else
         If Len(ControlUnidadesUSB1) < Len(ControlUnidadesUSB2) And ControlUnidadesUSB2 <> "$" Then
             Me.Print "EXPULCIÓN" + vbTab + ControlUnidadesUSB2 + vbTab & Time
             ControlUnidadesUSB2 = "$"
         Else
             Me.Print "SIN  DATOS" + vbTab + "···" + vbTab & Time
             ControlUnidadesUSB2 = UnidadesUSB
         End If
     End If
 End If
End Sub




NOTA 4: Saludos