GFCursor/Mfrm.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4695
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4695
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command2
      Caption         =   "Command2"
      Height          =   375
      Left            =   900
      TabIndex        =   2
      Top             =   2760
      Width           =   1815
   End
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   375
      Left            =   2820
      TabIndex        =   1
      Top             =   2760
      Width           =   1815
   End
   Begin VB.PictureBox Picture1
      Height          =   495
      Index           =   0
      Left            =   60
      ScaleHeight     =   435
      ScaleWidth      =   495
      TabIndex        =   0
      Top             =   60
      Width           =   555
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Use to save memory usually wasted for multiple instances of control cursors.
'
'NOTE: when developing GFSkinEngine I noticed that every object with a
'user‑defined cursor reserves space for two bitmaps in GDI memory, one
'bitmap for the cursor and one for its mask.
'By using GFCursor_Load every cursor file will be loaded once only,
'and the function returns a reference to an already loaded cursor image.
'Note that the target project must have a reference to StdOle2.tbl.
'Use 'GDIUsage' to verify this program handles GDI memory correctly.
'
'GFCursor_Reset
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'GFCursor
Dim CursorNumber As Integer
Dim CursorNameArray() As String
Dim CursorPictureArray() As New StdPicture

Private Sub Command1_Click()
    'on error resume next
    Dim PictureLoop As Integer
    For PictureLoop = 1 To 25
        Load Picture1(PictureLoop)
        Picture1(PictureLoop).Left = PictureLoop * Screen.TwipsPerPixelX * 2
        Picture1(PictureLoop).Top = PictureLoop * Screen.TwipsPerPixelY * 2
        Picture1(PictureLoop).Enabled = True
        Picture1(PictureLoop).Visible = True
        Picture1(PictureLoop).MousePointer = 99 'user‑defined
        Picture1(PictureLoop).MouseIcon = GFCursor_Load("C:\Autoexec.bat")
    Next PictureLoop
End Sub

Private Sub Command2_Click()
    'on error resume next 'click after Command1 has been clicked
    Dim PictureLoop As Integer
    Do 'hard‑core test, keep running some minutes and then use GDIUsage to verify no cursor stayed in memory
        For PictureLoop = 1 To 25
            Picture1(PictureLoop).MousePointer = 99 'user‑defined
            Picture1(PictureLoop).MouseIcon = GFCursor_Load("C:\Windows\cursors\arrow_i.cur")
        Next PictureLoop
        Call GFCursor_Reset
    Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'on error resume next
    Call GFCursor_Reset
End Sub

Private Function GFCursor_Load(ByVal CursorName As String) As StdPicture
    On Error GoTo Error: 'important (if cursor to load is invalid); always use to load a cursor or picture file, function will return a reference to an already loaded cursor/picture if possible
    Dim CursorLoop As Integer
    Dim TempStdPicture As New StdPicture
    'preset
    For CursorLoop = 1 To CursorNumber
        If UCase$(CursorNameArray(CursorLoop)) = UCase$(CursorName) Then
            Set GFCursor_Load = CursorPictureArray(CursorLoop)
            Exit Function
        End If
    Next CursorLoop
    'begin
    If Not ((Dir(CursorName) = "") Or (Right$(CursorName, 1) = "\") Or (CursorName = "")) Then 'verify
        If Not (CursorNumber = 32767) Then 'verify
            CursorNumber = CursorNumber + 1
        Else
            MsgBox "internal error in GFCursor_Load() (GFSkinEngine): overflow !", vbOKOnly + vbExclamation
            Exit Function
        End If
        Set TempStdPicture = LoadPicture(CursorName)
        ReDim Preserve CursorNameArray(1 To CursorNumber) As String
        ReDim Preserve CursorPictureArray(1 To CursorNumber) As New StdPicture
        CursorNameArray(CursorLoop) = CursorName
        Set CursorPictureArray(CursorLoop) = TempStdPicture
        Set GFCursor_Load = CursorPictureArray(CursorLoop) 'ok
    Else
        MsgBox "internal error in GFCursor_Load(): file '" + CursorName + "' not found !", vbOKOnly + vbExclamation
        Set GFCursor_Load = Nothing 'error
        Exit Function
    End If
    Exit Function
Error:
    MsgBox "internal error in GFCursor_Load(): file '" + CursorName + "' invalid !", vbOKOnly + vbExclamation
    Set GFCursor_Load = Nothing 'error
    Exit Function
End Function

Private Sub GFCursor_Reset()
    'on error resume next 'call to free up memory
    Dim CursorLoop As Integer
    'begin
    For CursorLoop = 1 To CursorNumber
        Call DeleteObject(CursorPictureArray(CursorLoop).Handle) 'make sure loaded images are removed from memory
    Next CursorLoop
    Erase CursorNameArray()
    Erase CursorPictureArray() 'free up class‑array memory
    CursorNumber = 0 'reset
    ReDim CursorNameArray(1 To 1) As String 'reset
    ReDim CursorPictureArray(1 To 1) As New StdPicture 'reset
End Sub


[END OF FILE]