Subclasificarea

       Un alt subiect deosebit de interesant pentru Visual Basic il constituie subclasificarea ('subclassing'). Aceasta este un concept care combina programarea din Visual Basic cu programarea cu ajutorul functiilor si mesajelor Windows pentru realizarea unor lucruri care in mod direct nu se pot realiza in Visual Basic. De fapt are loc o filtrare a mesajelor si o prelucrare a lor dupa necesitatile noastre.
       Sa luam un mic exemplu: cum se poate realiza, pt. un meniu, ca la trecerea cursorului peste o optiune sa fie afisata pe status bar citeva explicatii legate de optiunea respectiva din meniu. (la fel ca Windows Explorer-ul de exemplu)
       De fapt solutia consta in schimbarea functiei de prelucrare a mesajelor cu o functie definita de noi in care se verifica un anume mesaj. In cazul in care acesta apare prelucram acest mesaj dupa care apelam vechea functie de prelucrare a mesajelor. Daca mesajul asteptat de noi nu apare pur si simplu se apeleaza vechea functie de prelucrare a mesajelor. Schimbarea functiei de tratarea mesajelor o schimbam cu SetWindowLong la care trebuie sa-i dam 3 parametrii: hWnd-ul fereastrei, constanta GWL_WNDPROC si adresa noi functii de tratarea mesajelor, iar functia SetWindowLong returneaza vechea procedura de tratarea mesajelor. Adresa noii functii o dam cu ajutorul noului operator AddressOf (introdus in VB5). Antetul noii functii de tratare a mesajelor trebuie sa fie identic cu antetul unei functii Windows de tratare a mesajelor, in exemplul nostru
Public Function SystemMenuCallBack(ByVal lnghwnd As Long, ByVal lngMessage As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
unde lnghwnd este identificatorul ferestrei, lngMessage este mesajul primit, iar wParam si lParam sint parametri aditionali mesajului. In final se reface procedura de prelucrarea mesajelor la valoarea initiala prin apelul Functiei SetWindowLong cu valoarea initiala. Apelul vechii proceduri de prelucrare a mesajelor se face cu functia CallWindowProc care in plus fata de antetul unei functii de prelucrare a mesajelor mai are specificat si identificatorul pentru functia de prelucrare a mesajelor dorita (in cazul nostru se apeleaza cu identificatorul vechii functii de prelucrarea mesajelor).

Sa vedem acum programul concret pt. aceasta.
Mai intii punem pe o forma (frmMenuSample) un meniu de forma

Optiune1	Optiune		Exit
  Suboptiune11    Suboptiune21
  ------------
  Suboptiune12

si un statusbar (Statusbar1) cu Style = 1-sbrSimple
Adaugam un modul la proiect in care scriem:


Const WM_MENUSELECT = &H11F	'mesajele tratate de noi
Const WM_EXITMENULOOP = &H212	'    - // -
Const GWL_WNDPROC = (-4)	'constanta pentru specificarea functiei de prelucrarea mesajelor
Private mlngOldProcessID As Long ' identificatorul vechii functii de prelucrarea mesajelor

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
 (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _
 ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Sub SystemMenuSubClass()
'instaleaza noua functie de prelucrarea mesajelor si in acelasi timp salveaza
'identificatorul vechii functii de prelucrarea mesajelor (in mlngOldProcessID)
 mlngOldProcessID = SetWindowLong(frmMenuSample.hwnd, GWL_WNDPROC, _
   AddressOf SystemMenuCallBack)
End Sub

Public Function SystemMenuCallBack(ByVal lnghwnd As Long, ByVal lngMessage As Long, _
  ByVal wParam As Long, ByVal lParam As Long) As Long
'aceasta este noua functie de prelucrarea a mesajelor definita de noi in care sint 
'prelucrate doar mesajele care ne intereseaza
    If lngMessage = WM_MENUSELECT Then
      'iau ultimele 4 cifre hexa ale lui wParam
      Select Case Val(Right(CStr(Hex(wParam)), 4))
          Case 0
             frmMenuSample.StatusBar1.SimpleText = "Optiune 1"
          Case 1
             frmMenuSample.StatusBar1.SimpleText = "Optiune 2"
          Case 2
             frmMenuSample.StatusBar1.SimpleText = "Sub Optiune 1 - 1"
          Case 4
             frmMenuSample.StatusBar1.SimpleText = "Sub Optiune 1 - 2"
          Case 6
             frmMenuSample.StatusBar1.SimpleText = "Sub Optiune 2 - 1"
          Case 7
             frmMenuSample.StatusBar1.SimpleText = "Terminarea programului"
       End Select
    End If
    If lngMessage = WM_EXITMENULOOP Then frmMenuSample.StatusBar1.SimpleText = "Ready"
'apeleaza vechea functie de prelucrearea mesajelor indiferent daca am prelucrat si noi mesajul
'functia va returna valoarea returnata de vechea functie de prelucrarea mesajelor
SystemMenuCallBack = CallWindowProc(mlngOldProcessID, lnghwnd, lngMessage, wParam, lParam)
End Function

Public Sub SystemMenuRestore()
'reface vechea procedura de prelucrarea mesajelor
Call SetWindowLong(frmMenuSample.hwnd, GWL_WNDPROC, mlngOldProcessID)
End Sub

Citeva observatii legate de functia SystemMenuCallBack (aceasta poate avea orice alt nume dar trebuie sa respecte tipul parametrilor pe care ii are).
In cazul nostru ne intereseaza doua mesaje si anume WM_MENUSELECT si WM_EXITMENULOOP (primul apare cind selectam o optiune din meniu iar al doilea mesaj apare cind meniul pierde focusul si am iesit din meniu). Daca s-a primit primul mesaj atunci in wParam o sa avem optiunea din meniu selectata incepind cu 0 (=numarul primei optiune) pina la 7 (=numarul ultimei optiuni). In functie de optiunea selectata afisez textul corespunzator pe statusbar.
Daca am terminat lucrul cu meniul (la aparitia mesajului WM_EXITMENULOOP) afisez pe statusbar 'Ready'.

Forma are urmatorul cod:


Private Sub mnuExit_Click()
Unload Me
End Sub

Private Sub Form_Load()
StatusBar1.SimpleText = "Salut !"
SystemMenuSubClass  'aici instalez noua procedura de tratarea mesajelor
End Sub

Private Sub Form_Unload(Cancel As Integer)
'aici refac vechea procedura de tratarea mesajelor
SystemMenuRestore
End Sub

Private Sub mnusub11_Click()
MsgBox "SubOptiune1 la Optiune1"
End Sub

Private Sub mnusub12_Click()
MsgBox "SubOptiune2 la Optiune1"
End Sub

Private Sub mnusub21_Click()
MsgBox "SubOptiune1 la Optiune2"
End Sub

Un alt exemplu unde se poate folosi aceasta metoda de programare ar putea fi pentru cazul cind ne propunem sa realizam un program care sa stie de drag&drop, mai exact sa gasim numele fisierelor trase peste forma noastra (avind numele fisierelor mai departe se poate face orice cu aceste fisiere). De fapt este o combinatie de subclasificare si de utilizare a functiilor API Windows.
Punem pe o forma o lista (List1), 2 butoane de comanda: unul pentru terminare (cmdExit) si unul pentru stergerea listei (cmdSterge) si un checkbox pentru a accepta sau nu drag&drop-ul (chkAccept). De asemenea, adaugam la proiect un modul in care scriem:


Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
Declare Sub DragFinish Lib "shell32.dll" (ByVal HDROP As Long)
Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" _
 (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long

Public Const WM_DROPFILES = &H233
Const GWL_WNDPROC = (-4)
Private mlngOldProcessID As Long

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
 (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, _
 ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Sub SystemDragDropSubClass()
'instaleaza noua functie de prelucrarea mesajelor si in acelasi timp salveaza
'identificatorul vechii functii de prelucrarea mesajelor (in mlngOldProcessID)
 mlngOldProcessID = SetWindowLong(frmDragDrop.hwnd, GWL_WNDPROC, _
   AddressOf SystemDragDropCallBack)
End Sub

Public Function SystemDragDropCallBack(ByVal lnghwnd As Long, ByVal lngMessage As Long, _
  ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lpszFile As String * 255
Dim m As Boolean, nr As Long, i As Integer, x As Long
    If lngMessage = WM_DROPFILES Then
        nr = DragQueryFile(wParam, -1, lpszFile, 255)
        For i = 0 To nr - 1
            x = DragQueryFile(wParam, i, lpszFile, 255)
            frmDragDrop.List1.AddItem Left$(lpszFile, x)
        Next
        DragFinish (wParam)
        End If
SystemDragDropCallBack = CallWindowProc(mlngOldProcessID, lnghwnd, lngMessage, wParam, lParam)
End Function

Public Sub SystemDragDropRestore()
'reface vechea procedura de prelucrarea mesajelor
Call SetWindowLong(frmDragDrop.hwnd, GWL_WNDPROC, mlngOldProcessID)
End Sub

De fapt dupa acelasi principiu tratam in noua noastra functie pt. prelucrarea mesajelor doar mesajul WM_DROPFILES care apare in momentul cind am lasat fisiere peste forma noastra. Numele acestor fisiere se obtin prin apelarea functiilor API Windows DragQueryFile cu urmatorii parametri: identificatorul unei structuri a fisierelor lasate pe forma, indexul fisierului in structura anterioara (daca este -1 ne da numarul fisierelor), un bufer pt. numele unui fisier si lungimea numelui fisierului de index dat.
Deci in momentul aparitiei mesajului WM_DROPFILES citesc numarul fisierelor, iar apoi adaug fiecare fisier in lista, dupa care apelez functia DragFinish care elibereaza memoria ocupata de numele fisierelor. In continuare apelez vechea functie de tratarea mesajelor.
Programul din forma frmDragDrop este urmatorul:


Private Sub chkAccept_Click()
'Accepta sau nu drag&drop-ul fisierelor
If chkAccept.Value = vbChecked Then
DragAcceptFiles Me.hwnd, True
Else
DragAcceptFiles Me.hwnd, False
End If
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdSterge_Click()
List1.Clear
End Sub

Private Sub Form_Load()
'initial accepta drag&drop-ul fisierelor
DragAcceptFiles Me.hwnd, True
'instalarea noii functii de prelucrare a mesajelor
SystemDragDropSubClass
End Sub

Private Sub Form_Unload(Cancel As Integer)
'apelul procedurii de refacere
SystemDragDropRestore
End Sub

Acceptarea sau nu a drag&drop-ului fisierelor se face prin apelul unei alte functii API Windows si anume DragAcceptFiles care are 2 parametrii: identificatorul ferestrei si o valoare booleana care spune daca este acceptat sau nu drag&drop-ul.
Aceasi problema mai poate avea o solutie de aceasta data apelind la functiile API PeekMessage/TranslateMessage/DispatchMessage. Pt. asta se pune la Project Properties -> Starup Object = Sub Main si scrie intr-un modul urmatoarele (Form1 raminind nemodificata):


Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
Declare Sub DragFinish Lib "shell32.dll" (ByVal HDROP As Long)
Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" _
  (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long

Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, _
  ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, _
  ByVal wRemoveMsg As Long) As Long
Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Declare Function WaitMessage Lib "user32" () As Long

Type POINTAPI
        x As Long
        y As Long
End Type

Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Const WM_QUIT = &H12
Public Const WM_DROPFILES = &H233
Public Const PM_NOREMOVE = &H0
Public Const PM_REMOVE = &H1

Sub Main()
Dim t$
Dim lpMsg As MSG
Dim lpszFile As String * 255
Dim nr As Long, i As Integer, x As Long
Form1.Show
DragAcceptFiles Form1.hwnd, True
Do
 If PeekMessage(lpMsg, Form1.hwnd, 0&, 0&, PM_REMOVE) Then
    x = TranslateMessage(lpMsg)
    x = DispatchMessage(lpMsg)
    If lpMsg.message = WM_DROPFILES Then
        nr = DragQueryFile(lpMsg.wParam, -1, lpszFile, 255)
        For i = 0 To nr - 1
            x = DragQueryFile(lpMsg.wParam, i, lpszFile, 255)
            t$ = t$ & Left$(lpszFile, x) & vbCrLf
        Next
        DragFinish (lpMsg.wParam)
        MsgBox t$
        t$ = ""
     End If
 Else
    DoEvents
    x = WaitMessage
End If
Loop Until lpMsg.message = WM_QUIT
End Sub

De fapt creem un ciclu do...loop in care citim toate mesajele cu PeekMessage (+TranslateMessage +DispatchMessage pt. diverse prelucrari ale mesajelor) pina la aparitia mesajului WM_QUIT (de terminarea executiei).
Daca este mesajul WM_DROPFILES atunci il prelucram dupa cum vrem noi (citesc numele fisierelor lasate pe forma si le afisez cu MsgBox). Daca nu este nici un mesaj in coada, dam controlul Windowsului pt. prelucrarea altor evenimente si asteptam aparitia unui mesaj pt. programul nostru (cu WaitMessage).

Desi se pot face lucruri spectaculoase folosindu-se aceasta tehnica trebuie lucrat cu mare atentie pentru ca este foarte usor sa gresesti, iar aceste erori pot duce la blocarea sistemului sau doar inchiderea Visual Basicului deoarece se lucreaza cu elemente interne Windows-ului.