| Lo siento, es verdad. Pongo el codigo y lo explico un poco:
Public Sub Main()
With App
mlHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf fAppHook, .hInstance, .ThreadID)
frmPrincipal.Show
Call UnhookWindowsHookEx(mlHook)
End With
End Sub
Este es el procedimiento de inicio de la aplicacion.
Private Sub Form_Load()
Dim i As Integer
Dim Impresora As Printer
frmPrincipal.Caption = "ImprimeFuentes v." & App.Major & "." & App.Minor & "." & App.Revision
For i = 0 To Printer.FontCount - 1
lstFuentesImpresora.AddItem Printer.Fonts(i)
Next i
For i = 0 To Screen.FontCount - 1
lstFuentesPantalla.AddItem Screen.Fonts(i)
Next i
For Each Impresora In Printers
cmbImpresoras.AddItem Impresora.DeviceName
Next
mlWndProc = SetWindowLong(GetParent(lstFuentesImpresora.hwnd), GWL_WNDPROC, AddressOf fAppWndProc)
Call SaveSetting("OwnerDraw", CStr(GetParent(lstFuentesImpresora.hwnd)), "WndProcs", CStr(mlWndProc))
mlWndProc = SetWindowLong(GetParent(lstFuentesPantalla.hwnd), GWL_WNDPROC, AddressOf fAppWndProc)
Call SaveSetting("OwnerDraw", CStr(GetParent(lstFuentesPantalla.hwnd)), "WndProcs", CStr(mlWndProc))
End Sub
Este es el procedimiento de carga del formulario. Cada uno de los ListBox subclasificados esta dentro de un control FRAME.
Public Function fAppHook(ByVal lHookID As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Static bCombo As Boolean
Dim CWP As CWPSTRUCT
Dim k As Long
Dim sClass As String
Call CopyMemory(CWP, ByVal lParam, Len(CWP))
Select Case CWP.message
Case WM_CREATE
mlSetStyle = 0
sClass = Space$(128)
k = GetClassName(CWP.hwnd, ByVal sClass, 128)
sClass = Left$(sClass, k)
Select Case sClass
Case "ThunderListBox"
mlSetStyle = GetWindowLong(CWP.hwnd, GWL_STYLE)
mlSetStyle = mlSetStyle _
Or LBS_SORT _
Or LBS_OWNERDRAWVARIABLE _
Or LBS_HASSTRINGS
End Select
If mlSetStyle Then
mlHookWndProc = SetWindowLong(CWP.hwnd, GWL_WNDPROC, AddressOf fSetStyle)
End If
End Select
fAppHook = CallNextHookEx(mlHook, lHookID, wParam, ByVal lParam)
End Function
Este el procedimiento del HOOK (he eliminado algunas cosas que no vienen al caso)
Public Function fAppWndProc(ByVal hwnd As Long, _
ByVal Msg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim hdc As Long
Dim lRet As Long
Dim hBmp As Long
Dim lFont As Long
Dim sString As String
Dim tSize As SIZE
Dim hPic As StdPicture
Dim DIS As DRAWITEMSTRUCT
If hwnd <> mhWndLast Or mlWndProc = 0 Then
mlWndProc = Val(GetSetting("OwnerDraw", CStr(hwnd), "WndProcs"))
mhWndLast = hwnd
End If
Select Case Msg
Case WM_DRAWITEM
Call CopyMemory(DIS, ByVal lParam, Len(DIS))
Select Case DIS.CtlType
Case ODT_LISTBOX
With DIS
sString = Space$(128)
lRet = SendMessage(.hwndItem, LB_GETTEXT, .itemID, ByVal sString)
sString = Left$(sString, lRet)
lFont = CreateFont(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, sString)
Call SelectObject(.hdc, lFont)
Call GetTextExtentPoint32(.hdc, sString, Len(sString), tSize)
Call SendMessage(.hwndItem, LB_SETITEMHEIGHT, .itemID, ByVal tSize.cy)
If .itemState And ODS_SELECTED Then
Call SetBkColor(.hdc, GetSysColor(COLOR_HIGHLIGHT))
Call SetTextColor(.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))
Else
Call SetBkColor(.hdc, GetSysColor(COLOR_WINDOW))
Call SetTextColor(.hdc, GetSysColor(COLOR_WINDOWTEXT))
End If
End With
With DIS.rcItem
Call TextOut(DIS.hdc, .Left, .Top, sString, Len(sString))
End With
Call DeleteObject(lFont)
End Select
fAppWndProc = True
Exit Function
Case WM_PARENTNOTIFY
If (wParam And &HFF) = WM_DESTROY Then GoTo DestroyIt
Case WM_DESTROY
DestroyIt:
Call DeleteSetting("OwnerDraw", CStr(hwnd))
Call SetWindowLong(hwnd, GWL_WNDPROC, mlWndProc)
End Select
fAppWndProc = CallWindowProc(mlWndProc, hwnd, Msg, wParam, lParam)
End Function
Y este es el procedimiento que recibe los mensajes (WinProc). (He vuelto a omitir codigo innecesario).
Este codigo se ejecuta perfectamente desde el entorno de desarrollo, es decir, me muestra en cada uno de los ListBox, las fuentes. Pero cuando lo compilo ya no funciona.
Muchas gracias |