Mensajes

Hola BlackZeroX si funciona quizas lo probaste con un STATIC y no recibe el WM_MouseMove proba con BUTTON

Class1

Código [Seleccionar] Expandir


Option Explicit
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC As Long = -4
Private Const WM_DESTROY As Long = &H2

Private PrevWndProc As Long
Private bvASM(40) As Byte

Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" 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, lpParam As Any) As Long
Private Const WS_VISIBLE As Long = &H10000000
Private mWnd As Long

Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    WindowProc = CallWindowProcA(PrevWndProc, hwnd, Msg, wParam, lParam)

    If Msg = WM_DESTROY Then
        Call StopSubclassing(hwnd)
    End If
   
    Debug.Print Msg, wParam, lParam
End Function

Private Sub SetSubclassing(Obj As Object, hwnd As Long)
    Dim WindowProcAddress As Long
    Dim pObj As Long
    Dim pVar As Long

    Dim i As Long

    For i = 0 To 40
        bvASM(i) = Choose(i + 1, &H55, &H8B, &HEC, &H83, &HC4, &HFC, &H8D, &H45, &HFC, &H50, &HFF, &H75, &H14, _
                                 &HFF, &H75, &H10, &HFF, &H75, &HC, &HFF, &H75, &H8, &H68, &H0, &H0, &H0, &H0, _
                                 &HB8, &H0, &H0, &H0, &H0, &HFF, &HD0, &H8B, &H45, &HFC, &HC9, &HC2, &H10, &H0)
    Next i

    pObj = ObjPtr(Obj)

    Call CopyMemory(pVar, ByVal pObj, 4)
    Call CopyMemory(WindowProcAddress, ByVal (pVar + 28), 4)

    Call LongToByte(pObj, bvASM, 23)
    Call LongToByte(WindowProcAddress, bvASM, 28)

    PrevWndProc = SetWindowLongA(hwnd, GWL_WNDPROC, VarPtr(bvASM(0)))
End Sub

Private Sub StopSubclassing(hwnd)
    Call SetWindowLongA(hwnd, GWL_WNDPROC, PrevWndProc)
End Sub

Private Sub LongToByte(ByVal lLong As Long, ByRef bReturn() As Byte, Optional i As Integer = 0)
    bReturn(i) = lLong And &HFF
    bReturn(i + 1) = (lLong And 65280) / &H100
    bReturn(i + 2) = (lLong And &HFF0000) / &H10000
    bReturn(i + 3) = ((lLong And &HFF000000) \ &H1000000) And &HFF
End Sub

Private Sub Class_Initialize()
    mWnd = CreateWindowEx(0&, "Button", "Hola Mundo", WS_VISIBLE, 0&, 0&, 300, 300, 0&, 0&, App.hInstance, ByVal 0&)
    If mWnd <> 0 Then Call SetSubclassing(Me, mWnd)
End Sub

Private Sub Class_Terminate()
    If mWnd <> 0 Then
        Call StopSubclassing(mWnd)
        DestroyWindow mWnd
    End If
End Sub


Saludos.

Simplemente asombroso la verdad acostumbrado a utilizar la clase de Paul Caton  que son muchisimas lineas, con esto esta barbaro.

para informacion a todos, si quieren utilizarlo desde un modulo clase cambiar este valor en esta linea

Código [Seleccionar] Expandir

Call CopyMemory(WindowProcAddress, ByVal (pVar + 1784), 4)
para un modulo clase cambiar 1784 por 28
y para un User Control  por 1956

Seguramente me surjan algunas dudas mas adelante sobre como implementar un subclass y un Api Timer en un mismo modulo o bien dos Sub para distintos hilos.
si tenes idea postealo para agendarlo.

Saludos.

muy bueno F3B14N, veo que eliminaste VirtualAlloc y VirtualFree con lo que se termino el problema que mencionaba anteriormente al parecer todo funciona de lujo  , además se simplifico mucho mas.

Gracias por compartirlo.

PD: fijate quizas te guste mas para crear el ASM(), creo que asi lo hacia Cobein.

Código [Seleccionar] Expandir


        Dim sCode As String

   
        sCode = "90FF05000000006A0054FF742418FF742418FF742418FF7424186800000000B800000000FFD0FF0D00000000A10000000085C075" & _
                "0458C21000A10000000085C0740458C2100058595858585868008000006A00680000000051B800000000FFE00000000000000000"
               
        For i = 0 To Len(sCode) - 1 Step 2
            bvASM(i / 2) = CByte("&h" & Mid$(sCode, i + 1, 2))
        Next

Saludos.

@BlackZerox: Quitale el punto al final

creo que lo mejor que veas estos links
http://www.activevb.de/tutorials/tut_subclass_asm/tut_subclass_asm.html

y descargate este .zip que esta muy bueno.

http://www.activevb.de/rubriken/klassen/windows/csubclasser/subclasser.zip

pd: yo estoy utilzando estas clases y uc pero me me suelen crashear cuando llama a VirtualFree, creo que esto ocurre cuando llega un msg a WindowProc  y llame a VirtualFree, no quiero dar un ejemplo exacto para no irme por las ramas pero si alguien le encuentra una solución o quiere que entre en detalles que chifle.

Saluods.

hola la verdad skinear el scroll es un verdadero dolor de cabeza, lo mejor es empezar desde 0 creando un usercontrol de un scroll diseñado a gusto y luego recrear todo el control, a la larga es mas facil.

Saludos.

Hola, me da error 53 no se ha encontrado el archivo nadaesloqueparece, estoy en windows 7 32 bits
el id seria el ordinal del MessageBoxA ? , no testie si es el 2 quizas ese sea el problema.

Saludos.

Hola aun no entiendo mucho el proposito o bien como funciona, vos recolectas datos de personas para luego enviarle algun tipo de spam o lo que fuere, bien con que cuenta le envias ese spam, ¿se puede enviar un mensage a alguien que no tenes como contacto sin algun tipo de capcha?

en respuesta al proyecto mio aun funciona bien.

Saludos.

Hola no te combiene superponer el control sobre el listview, lo mejor es si dibujar el boton de Drop cuando el item tiene el foco ya que el control combo box casi seguro tiene otro tamaño que el item del listview y este no es ajustable, entonces cuando haces click dibjuas el Drop con el api DrawEdge  o con DrawThemeBackground (si es que queres utilizas los Temas de windows) entonces si haces clik o doble clik llevas un combobox Visible=false justo sobre el RECT del item y desplegas la lista utilizando SendMessage

no se si me entendes pero la idea es utilizar solo un combobox y dibujar los dropbutons

Saludos.

Hola mira no se si es el mimsmo .BMD que el Mu leelo bien y analizalo estan todas las extructuras

http://www.amnoid.de/gc/bmd.txt

Mucha suerte 

Aca esta mi función

Código (Vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long

Private Type BuferColor
    Color As Long
    Count As Long
End Type

Private Sub Form_Load()
    Picture1.AutoRedraw = True
    Me.BackColor = GetMaskColor(Picture1)
End Sub

Private Function GetMaskColor(oPic As PictureBox) As Long
    Dim i As Long, j As Long, x As Long
    Dim lWidth As Long, lHeight As Long
    Dim NumIcon As Long
    Dim aColors() As Long
    Dim BC() As BuferColor
    Dim bFind As Boolean
    Dim lMax As Long, ArrSize As Long
   
    lWidth = (oPic.ScaleWidth \ oPic.ScaleHeight)
    If lWidth = 0 Then lWidth = 1
    lWidth = oPic.ScaleWidth \ lWidth
    lHeight = oPic.ScaleHeight
   
    NumIcon = oPic.ScaleWidth \ lWidth
   
    ArrSize = (NumIcon * 4) - 1
   
    ReDim aColors(ArrSize)

   
    For i = 0 To NumIcon - 1
        aColors(j) = GetPixel(oPic.hdc, x, 0)
        aColors(j + 1) = GetPixel(oPic.hdc, x + lWidth - 1, 0)
        aColors(j + 2) = GetPixel(oPic.hdc, x, lHeight - 1)
        aColors(j + 3) = GetPixel(oPic.hdc, x + lWidth - 1, lHeight - 1)
        j = j + 4
        x = x + lWidth
    Next
   
    ReDim BC(ArrSize)
    x = 0
   
    For i = 0 To ArrSize
       bFind = False
       For j = 0 To x
            If BC(j).Color = aColors(i) Then
                BC(j).Count = BC(j).Count + 1
                bFind = True
                Exit For
            End If
       Next
       If Not bFind Then BC(x).Color = aColors(i): x = x + 1
    Next

    For i = 0 To x - 1
        If BC(i).Count > lMax Then
            lMax = BC(i).Count
            GetMaskColor = BC(i).Color
        End If
    Next

End Function


Seba la idea es obtener un color final, puede que alla un empate en la cantidad de colores  pero almenos es una aproximación

Saludos.