Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0765: Effizienter Mauscursor, leichte Objekte

VB 5/6-Tipp 0765: Effizienter Mauscursor, leichte Objekte

 von OlimilO

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory, Sleep

Download: Download des Beispielprojektes [3.78 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Private mc As TMouseCursor

Private Sub Form_Load()
    New_MouseCursor(mc) = vbCrosshair
End Sub

Private Sub Command1_Click()

    Dim mc As TMouseCursor: New_MouseCursor(mc) = vbArrowHourglass
    
    Call Sleep(500)
    Call ReadAHugeFile
    
    Call Sleep(500)
    Call ReadAHugeFile
    
    Call Sleep(500)
    
End Sub

Public Sub ReadAHugeFile()
    Dim mc As TMouseCursor: New_MouseCursor(mc) = vbHourglass
    Call Sleep(2000)
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'----- Anfang Modul "ModIUnknown" alias ModIUnknown.bas -----
Option Explicit
'wird von QueryInterface zurückgegeben, falls das Objekt kein Interface hat:
Public Const E_NOINTERFACE As Long = &H80004002

'dies ist der typische VTable der Schnittstelle IUnknown
Public Type TIUnknownVTable
    PQueryInterface As Long
    PAddRef         As Long
    PRelease        As Long
End Type
'auch bekannt als Alias MoveMemory, Alias CopyMemory, Alias cpymem etc.
Public Declare Sub RtlMoveMemory Lib "kernel32" ( _
    ByRef pDst As Any, ByRef pSrc As Any, ByVal bytLength As Long)

'die folgenden drei Funktionsrümpfe kann man so übernehmen, und werden
'in jedem Objekt gebraucht.
Private Function QueryInterface(this As TIUnknownVTable, riid As Long, pvObj As Long) As Long
    'pvObj = 0
    'bei Objekten die kein Interface haben:
    'QueryInterface = E_NOINTERFACE
End Function
Private Function AddRef(this As TIUnknownVTable) As Long
    'hier wird eine Referenz hinzugefügt
End Function
Private Function Release(this As TIUnknownVTable) As Long
    'hier wird eine Referenz abgezogen
End Function

Public Function FncPtr(ByVal pfn As Long) As Long
    FncPtr = pfn
End Function
'------ Ende Modul "ModIUnknown" alias ModIUnknown.bas ------
'--- Anfang Modul "ModMouseCursor" alias ModMouseCursor.bas ---
Option Explicit

Private mIUVTable As TIUnknownVTable
Private mpVTable  As Long '= VarPtr(mIUVTable)

Public Type TMouseCursor
    pVTable     As Long
    pThisObject As IUnknown
    PrevCursor  As VBRUN.MousePointerConstants
End Type

'das Propertyprefix "New_" soll daran erinnern, daß hier ein Objekt erstellt wird !-)
Public Property Let New_MouseCursor(this As TMouseCursor, NewCursor As VBRUN.MousePointerConstants)
    
    If mpVTable = 0 Then
        
        'so jetzt muß man zuerst mal die Funktionspointer ermitteln
        'das wird aber nur ein einzigesmal im gesamten Projekt gemacht!
        With mIUVTable
            .PQueryInterface = FncPtr(AddressOf QueryInterface)
            .PAddRef = FncPtr(AddressOf AddRef)
            .PRelease = FncPtr(AddressOf Release)
        End With
        mpVTable = VarPtr(mIUVTable)
    
    End If
    With this
        
        'den vorherigen MouseCursor in der Variable speichern
        .PrevCursor = Screen.MousePointer
        .pVTable = mpVTable
        Call RtlMoveMemory(.pThisObject, VarPtr(.pVTable), 4)
    
    End With
    
    'hier jetzt den neuen MouseCursor zuweisen
    Screen.MousePointer = NewCursor
    
End Property

'hier jetzt die drei Funktionsrümpfe von ModIUnknown reinkopieren:
'sie werden natürlich noch angepasst

'die folgenden drei Funktionsrümpfe kann man so übernehmen, und werden
'in jedem Objekt gebraucht.
Private Function QueryInterface(this As TMouseCursor, riid As Long, pvObj As Long) As Long
    
    pvObj = 0
    'bei Objekten die kein Interface haben:
    QueryInterface = E_NOINTERFACE
    
End Function

Private Function AddRef(this As TMouseCursor) As Long
    
    'hier wird eine Referenz hinzugefügt
    'im Objekt MouseCursor brauchen wir das aber garnicht
    
End Function

Private Function Release(this As TMouseCursor) As Long
    
    'hier wird eine Referenz abgezogen
    'wird diese Funktion einmalig aufgerufen,
    'dann den alten MouseCursor wiederherstellen
    Screen.MousePointer = this.PrevCursor
    
End Function

'--- Ende Modul "ModMouseCursor" alias ModMouseCursor.bas ---
'-------------- Ende Projektdatei Projekt1.vbp --------------