Class Events

G

Gareth

Hi NG,

I've created a class that builds on a (large) Label and, with a host of
other labels (placed beneath the main label), acts as a clickable grid.

This grid is placed on a userform at run time. The events, selection of
objects etc. are handled within the class. I want to expand this however
such that an event such as a doubleclick on certain objects will fire as
an event within the parent userform's module i.e. expose something like:

Private Sub myGrid_DblClick(myRow as integer, myCol as integer, _
myID as integer)

End Sub

My assumption is that this isn't possible since the Grid isn't
instantiated until run time. (And I would definitely rather not have the
class module calling a procedure within the userform.)

Is my only option to make an OCX for this class so I can incorporate it
at design time (and accept all the deployment issues) or am I
overlooking something?

Thanks for any help,
Gareth

....The answer may well be in my copy of Power Programming by Mr
Walkenbach but it's packed up in boxes with all my other books...
 
G

Gareth

Hi Tom,

Thanks very much for your reply. John's example handles the events
within the class module - which is what I already do. I'm really looking
to bring the events outside of the class module.

The reason for this is that I want to keep my grid generic. It allows
the user to multiselect grid "cells" on mouse down, has methods to
accept arguments to create new objects on the grid and various
parameters (no of cols, width etc.) -- in order that I can just drop it
into other (disparate) applications without having to amend the class
itself and thereby avoiding any customization for individual apps.

The best workaround I've found is to expose a string property,
clsGrid.OnDoubleClick, that is set by the userform instantiating the
class with the name of the procedure to call upon a doubleclick.

e.g.
In Userform :
'code to make grid then:
With GRID
.gCol = etc. etc. etyc.
.OnDoubleClick = Thisworbook & "!" & "Event_GridDoubleClicked"
End With

In my class module I have:
Public OnDoubleClick As String
'loads of other stuff handling selection, mouse moves etc.
Private Sub GridControl_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
DIm myID as Long
myID = fcnGetIDFromXY(X,Y) ' which I know from mouse move traps
Application.Run OnDoubleClick (myID)
End Sub

And then in a standard module I have:

Sub Event_GridDoubleClicked(MyID as Long)
MsgBox "hurray"
myData = ADO_GetRecordFromDB (myID)
GRID.UpdateRecord myData
End Sub


But I don't like passing the function name - it seems a bit messy. And I
have to put the procedure to be run in a standard module also since I
can't get application.run to work with
thisworkbook.name!userform1.procedurename.

I guess neither of these are showstoppers, but it would be nice to keep
everything in its place and not mix up my class code with the userform.
Particularly when I would like to use the grid on two different forms
since they both have different data sources. If I don't use the 'set
OnDoubleClick' method - it would mean I would need to have two almost
identical class modules - or handle the two of them within the one class
module - which doesn't lend itselfeasily to further expansion.

Hence... I'm thinking maybe an OCX is the way to go..?

Thanks again,
Gareth
 
P

Peter T

Hi Gareth,

I'm sure I'm missing things from your combined posts, could you clarify -

Do you have just the one instance of Class to trap events of your "Large"
label. If so why do you need a separate class.

Or, referring to your first post, do you instanciate classes for each label
hidden under the main large label. If so how do events for these get
triggered. However if this is indeed what you are doing why do you need to
get the XY coordinates to work out the id of the control the mouse is over,
why not set the id to a class level variable at the moment you instanciate
the class.

Why are you using Application.Run to call a procedure within the same
project, and why do you need to pass the name of a procedure as an argument,
instead of say an If-Else or Select Case construct.

What's the problem of the Class(s) not being instanciated until run time.
Typically Withevents class's are set in the form's initialize event just
before the form is activated for the first time.

How/where do you store ref's to your Class(s), an array or collection I
assume if multiple classes. If public in a normal module you can call all
the methods of a class and access it's properties from anywhere, if that's
an issue.
I can't get application.run to work with
thisworkbook.name!userform1.procedurename.
Click to expand...

Again why application.run and the thisworkbook.name! qualifier. Providing
the proc in the userform is not Private why not simply
userform1.procedurename (arg's).

Regards,
Peter T
 
G

Gareth

Hi Peter,

Thanks for replying - I think you're right - my posts haven't been that
clear.

I have just one class - and that's all I want to use, for this part at
least.

The labels hidden under the large label are classless - they have no
events since they never get clicked (they're always underneath).

I want the logic of the control to follow thus:

When double clicked, tell the parent form that it's been doubleclicked
and let the parent form decide what to do with it.

I don't want:
To have the class go off and query the database, populate everything
etc. because that means the class is no longer generic - it's tied into
one application and must be modified for use in another.

Since I can't create an event procedure called MyGrid_DoubleClick in the
userform module I thought I could just set a string in the class called
OnDoubleClick which was the name of a procedure. This works - but only
if the procedure is in a standard module. I can't get it to work with
Userform1.MyProcedureName - whether or not it's Private, not private or
public. Other than that, this solution is acceptable I guess. I just
don't like having it in a standard module.

You're right - I could use an If Else construct but again that means the
Class is not generic.

In case you're still interested (!) I've copied some example code to
demonstrate the direction I'm heading in. It's crude but it works and
can just be copied and pasted into a new workbook without any modifications.

Just run userform1 and make a selection on the grid using left mouse
button and moving it left or right and then right click on it. (I'm
using right click rather than double click for this example.)


Many thanks,
G



'-----IN USERFORM1----------------
Option Explicit
Private Const GRID_START_Y As Integer = 20
Private Const GRID_START_X As Integer = 50
Private Const GRID_ROW_HEIGHT As Integer = 20
Private Const GRID_COL_WIDTH As Integer = 25
Private Const GRID_NO_OF_ROWS As Integer = 10
Private Const GRID_NO_OF_COLS As Integer = 24

Private Sub UserForm_Initialize()
With Me
.Height = 450
.Width = 700
End With
DrawGrid
End Sub

Sub DrawGrid()

Dim lblGrid As MSForms.Label

'Make our main grid label
Set lblGrid = Me.Controls.Add("Forms.Label.1", "GRID", True)

With lblGrid
'size grid control as desired
.Left = GRID_START_X
.Top = GRID_START_Y
.Height = GRID_NO_OF_ROWS * GRID_ROW_HEIGHT
.Width = GRID_NO_OF_COLS * GRID_COL_WIDTH
End With

'create the grid control
Set GRID.GridControl = lblGrid
'tidy up
Set lblGrid = Nothing

'set parameters for the grid
With GRID
.Start_X = GRID_START_X
.Start_Y = GRID_START_Y
.RowHeight = GRID_ROW_HEIGHT
.ColWidth = GRID_COL_WIDTH
.NoOfRows = GRID_NO_OF_ROWS
.NoOfCols = GRID_NO_OF_COLS
Set .GridParent = Me
'format the grid as per settings
.FormatGridControl

'set the procedure to be called in the event _
'of a right clik on the grid
.OnRightClick = "Event_GridRightClicked"
End With

End Sub

'---------------

'--IN A STANDARD MODULE-------------
Option Explicit
Public GRID As New clsGrid

Sub Event_GridRightClicked()
GRID.CreateBlock "TEST"
End Sub
'---------------

'--IN A CLASS MODULE NAMED clsGrid-------------
Option Explicit

Public WithEvents GridControl As MSForms.Label

'Settings for the grid
Public Start_Y As Integer
Public Start_X As Integer
Public RowHeight As Integer
Public ColWidth As Integer
Public NoOfRows As Integer
Public NoOfCols As Integer

Public GridParent As MSForms.UserForm


Public blnMouseButtonAlreadyDown As Boolean

Public GridSelection As Collection
Public SelectionCurrentRow As Integer
Public SelectionCurrentCol As Integer
Public SelectionMinCol As Integer
Public SelectionMaxCol As Integer

Public GridBlocks As Collection

Public OnRightClick As String

Private Sub Class_Initialize()
Set GridSelection = New Collection
Set GridBlocks = New Collection
SelectionCurrentRow = -1
SelectionCurrentCol = -1
End Sub
Sub FormatGridControl()
Dim iCol As Integer
Dim myLbl As MSForms.Label

'draw the back labels for the grid
For iCol = 0 To NoOfCols - 1
Set myLbl = GridParent.Controls.Add("Forms.Label.1", _
"BackDrop_Col" & iCol, True)
With myLbl
.Left = Start_X + (ColWidth * iCol)
.Width = ColWidth
.Top = Start_Y
.Height = NoOfRows * RowHeight
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 180)
.BackColor = RGB(255, 255, 255)
' .ZOrder = 1
End With
Next iCol

'format the main label as per user settings
With Me.GridControl
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 0)
.SpecialEffect = fmSpecialEffectSunken
.BackStyle = fmBackStyleTransparent
.ZOrder 0
End With



Set myLbl = Nothing

End Sub
Private Sub GridControl_Click()

If blnMouseButtonAlreadyDown Then
blnMouseButtonAlreadyDown = False
Else
fcnClearSelection
End If
End Sub

Private Sub GridControl_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'handle right clicking
If Not Button = 2 Then Exit Sub

If GridSelection.Count = 0 Then
MsgBox "pls select something"
Exit Sub
End If
Application.Run OnRightClick

End Sub

Private Sub GridControl_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Dim newCol As Integer, newRow As Integer
'we want to trap when someone holds the mouse button down
If Button <> 1 Then Exit Sub

' the mouse button isn't already down then this is a new selection
If Not blnMouseButtonAlreadyDown Then
'clear any existing "selections" from our collection
fcnClearSelection
End If

'we want to create a label on the grid to represent a selection
newRow = fcnCalculateGridRowFromY(Y)
newCol = fcnCalculateGridColFromX(X)

'if it's the same cell as last time then exit
If newRow = SelectionCurrentRow And newCol = SelectionCurrentCol
Then Exit Sub

'if this is a new row then set this row as our selection row
'clear our selection and exit
If SelectionCurrentRow = -1 Then SelectionCurrentRow = newRow

'If this is a different row than last time then
'we ignore
If SelectionCurrentRow <> newRow Then Exit Sub

'if this isn't the same as the previous column then we want to add a
label
If SelectionCurrentCol <> newCol And newCol <= NoOfCols - 1 Then

If SelectionMinCol = -1 Then
SelectionMinCol = newCol
ElseIf SelectionCurrentCol < SelectionMinCol Then
SelectionMinCol = SelectionCurrentCol
End If
If SelectionCurrentCol > SelectionMaxCol Then _
SelectionMaxCol = SelectionCurrentCol

fcnAddNewSelectionLabel newRow
SelectionCurrentCol = newCol
blnMouseButtonAlreadyDown = True

End If




End Sub

Function fcnCalculateGridRowFromY(Y As Single) As Integer
fcnCalculateGridRowFromY = CInt(Y / RowHeight - 0.499999)
End Function
Function fcnCalculateGridColFromX(X As Single) As Integer
fcnCalculateGridColFromX = CInt(X / ColWidth - 0.499999)
End Function

Sub fcnClearSelection()
While GridSelection.Count > 0
GridParent.Controls.Remove GridSelection(1).Name
GridSelection.Remove 1
Wend
SelectionCurrentCol = -1
SelectionCurrentRow = -1
SelectionMinCol = -1
SelectionMaxCol = -1

End Sub
Sub fcnAddNewSelectionLabel(myRow As Integer)

Dim myLbl As MSForms.Label
Dim iCol As Integer


'We insert this selection label but also
'check that we haven't missed any cells
'(this occurs when the mouse moves too fast
'or the user hits another row while moving the mouse)
For iCol = SelectionMinCol To SelectionMaxCol

'check whether this label already exists in our collection
If Not fcnKeyAlreadyExistsInCollection("R" _
& myRow & "C" & iCol, GridSelection) Then

'create the control
Set myLbl = GridParent.Controls.Add("Forms.Label.1", _
"R" & myRow & "C" & iCol, True)
With myLbl
.Left = Start_X + iCol * ColWidth
.Top = Start_Y + myRow * RowHeight
.Height = RowHeight
.Width = ColWidth
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(200, 0, 0)
.BackColor = RGB(255, 0, 0)
End With

On Error Resume Next
GridSelection.Add myLbl, "R" & myRow & "C" & iCol

End If

Next iCol

'bring the main grid label back to the front
Me.GridControl.ZOrder 0

End Sub
Function fcnKeyAlreadyExistsInCollection(myKey As String, _
myColl As Collection) As Boolean
'checks a given collection to see if a key already exists in there

On Error Resume Next
If myColl(myKey).Name = "X" Then
Exit Function
End If
fcnKeyAlreadyExistsInCollection = True
End Function
Sub CreateBlock(myCaption As String)
Dim myTextBox As MSForms.TextBox

Set myTextBox = GridParent.Controls.Add("Forms.Textbox.1", _
"Block_" & "R" & SelectionCurrentRow & "C" & SelectionMinCol, True)

With myTextBox
.BackColor = RGB(255, 255, 0)
.Text = myCaption
.Left = Start_X + SelectionMinCol * ColWidth
.Top = Start_Y + SelectionCurrentRow * RowHeight
.Height = RowHeight
.Width = (SelectionMaxCol - SelectionMinCol + 1) * ColWidth
End With
Set myTextBox = Nothing

'bring the main grid label back to the front
Me.GridControl.ZOrder 0
'add to my collection
'DO THIS LATER'

fcnClearSelection

End Sub
'-----------------------------------------
 
G

Gareth

Yuck - just realised the grid looks flickers when you make a selection.
That's because for the purposes of this demo, when simplifying it, I
added the line
Me.GridControl.ZOrder 0
to fcnAddNewSelectionLabel
so you could rightclick on a selection.

I've removed this to get rid of the flickering. Thus the labels remain
on top to prevent any more click events firing. This means (for the
demo) you have to rightclick elsewhere on the grid after you've made
your selection. This might seem like strange functionality to implement
but it's for the purposes of this demo only - I don't actually use it in
the long run - and the question of "making events for a class available
in the userform module" stands as originally.

Thanks

class module should read as follows:
'-------------------------
Option Explicit

Public WithEvents GridControl As MSForms.Label

'Settings for the grid
Public Start_Y As Integer
Public Start_X As Integer
Public RowHeight As Integer
Public ColWidth As Integer
Public NoOfRows As Integer
Public NoOfCols As Integer

Public GridParent As MSForms.UserForm


Public blnMouseButtonAlreadyDown As Boolean

Public GridSelection As Collection
Public SelectionCurrentRow As Integer
Public SelectionCurrentCol As Integer
Public SelectionMinCol As Integer
Public SelectionMaxCol As Integer

Public GridBlocks As Collection

Public OnRightClick As String

Private Sub Class_Initialize()
Set GridSelection = New Collection
Set GridBlocks = New Collection
SelectionCurrentRow = -1
SelectionCurrentCol = -1
End Sub
Sub FormatGridControl()
Dim iCol As Integer
Dim myLbl As MSForms.Label

'draw the back labels for the grid
For iCol = 0 To NoOfCols - 1
Set myLbl = GridParent.Controls.Add("Forms.Label.1", _
"BackDrop_Col" & iCol, True)
With myLbl
.Left = Start_X + (ColWidth * iCol)
.Width = ColWidth
.Top = Start_Y
.Height = NoOfRows * RowHeight
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 180)
.BackColor = RGB(255, 255, 255)
' .ZOrder = 1
End With
Next iCol

'format the main label as per user settings
With Me.GridControl
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 0)
.SpecialEffect = fmSpecialEffectSunken
.BackStyle = fmBackStyleTransparent
.ZOrder 0
End With



Set myLbl = Nothing

End Sub
Private Sub GridControl_Click()

If blnMouseButtonAlreadyDown Then
blnMouseButtonAlreadyDown = False
Else
fcnClearSelection
End If
End Sub

Private Sub GridControl_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'handle right clicking
If Not Button = 2 Then Exit Sub

If GridSelection.Count = 0 Then
MsgBox "pls select something"
Exit Sub
End If
Application.Run OnRightClick

End Sub

Private Sub GridControl_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Dim newCol As Integer, newRow As Integer
'we want to trap when someone holds the mouse button down
If Button <> 1 Then Exit Sub

' the mouse button isn't already down then this is a new selection
If Not blnMouseButtonAlreadyDown Then
'clear any existing "selections" from our collection
fcnClearSelection
End If

'we want to create a label on the grid to represent a selection
newRow = fcnCalculateGridRowFromY(Y)
newCol = fcnCalculateGridColFromX(X)

'if it's the same cell as last time then exit
If newRow = SelectionCurrentRow And newCol = SelectionCurrentCol
Then Exit Sub

'if this is a new row then set this row as our selection row
'clear our selection and exit
If SelectionCurrentRow = -1 Then SelectionCurrentRow = newRow

'If this is a different row than last time then
'we ignore
If SelectionCurrentRow <> newRow Then Exit Sub

'if this isn't the same as the previous column then we want to add a
label
If SelectionCurrentCol <> newCol And newCol <= NoOfCols - 1 Then

If SelectionMinCol = -1 Then
SelectionMinCol = newCol
ElseIf SelectionCurrentCol < SelectionMinCol Then
SelectionMinCol = SelectionCurrentCol
End If
If SelectionCurrentCol > SelectionMaxCol Then _
SelectionMaxCol = SelectionCurrentCol

fcnAddNewSelectionLabel newRow
SelectionCurrentCol = newCol
blnMouseButtonAlreadyDown = True

End If




End Sub

Function fcnCalculateGridRowFromY(Y As Single) As Integer
fcnCalculateGridRowFromY = CInt(Y / RowHeight - 0.499999)
End Function
Function fcnCalculateGridColFromX(X As Single) As Integer
fcnCalculateGridColFromX = CInt(X / ColWidth - 0.499999)
End Function

Sub fcnClearSelection()
While GridSelection.Count > 0
GridParent.Controls.Remove GridSelection(1).Name
GridSelection.Remove 1
Wend
SelectionCurrentCol = -1
SelectionCurrentRow = -1
SelectionMinCol = -1
SelectionMaxCol = -1

End Sub
Sub fcnAddNewSelectionLabel(myRow As Integer)

Dim myLbl As MSForms.Label
Dim iCol As Integer


'We insert this selection label but also
'check that we haven't missed any cells
'(this occurs when the mouse moves too fast
'or the user hits another row while moving the mouse)
For iCol = SelectionMinCol To SelectionMaxCol

'check whether this label already exists in our collection
If Not fcnKeyAlreadyExistsInCollection("R" _
& myRow & "C" & iCol, GridSelection) Then

'create the control
Set myLbl = GridParent.Controls.Add("Forms.Label.1", _
"R" & myRow & "C" & iCol, True)
With myLbl
.Left = Start_X + iCol * ColWidth
.Top = Start_Y + myRow * RowHeight
.Height = RowHeight
.Width = ColWidth
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(200, 0, 0)
.BackColor = RGB(255, 0, 0)
End With

On Error Resume Next
GridSelection.Add myLbl, "R" & myRow & "C" & iCol

End If

Next iCol

'bring the main grid label back to the front
'Me.GridControl.ZOrder 0

End Sub
Function fcnKeyAlreadyExistsInCollection(myKey As String, _
myColl As Collection) As Boolean
'checks a given collection to see if a key already exists in there

On Error Resume Next
If myColl(myKey).Name = "X" Then
Exit Function
End If
fcnKeyAlreadyExistsInCollection = True
End Function
Sub CreateBlock(myCaption As String)
Dim myTextBox As MSForms.TextBox

Set myTextBox = GridParent.Controls.Add("Forms.Textbox.1", _
"Block_" & "R" & SelectionCurrentRow & "C" & SelectionMinCol, True)

With myTextBox
.BackColor = RGB(255, 255, 0)
.Text = myCaption
.Left = Start_X + SelectionMinCol * ColWidth
.Top = Start_Y + SelectionCurrentRow * RowHeight
.Height = RowHeight
.Width = (SelectionMaxCol - SelectionMinCol + 1) * ColWidth
End With
Set myTextBox = Nothing

'bring the main grid label back to the front
Me.GridControl.ZOrder 0
'add to my collection
'DO THIS LATER'

fcnClearSelection

End Sub
 
P

Peter T

Hi Gareth,

I ran your code and sort of see what you are doing, though not of course how
it relates to your entire project and which parts you want to keep as
generic for use in other projects. So the following may not be relevant.

First, I don't see why you need a Withevents class for just your single
"large" label. The events already exit in the userform. Could pass the XY
coord's of mouse move over the large label to a proc elsewhere, possibly in
a non withevents class to do stuff.

But I don't even see why you need the large label at all. Why not dispense
with that and set multiple instance's of a withevents class to handle events
for each of the grid labels.

In this collection or array of classes you only need to be concerned with
label.left, label.width and the Y coordinate to calc' to draw and resize a
single red label. Eventually user can click that to create the textbox and
remove the temporary red label. Perhaps set an extra instance of the same
labels class to handle the red label, thereby avoiding the necessity to
"name" its click event in code. (in the class click event - If clsLab.name =
varLabelname Then)

Also you could have set whatever unique properties for each label class, as
required for other purposes, when these classes were created.

Regards,
Peter T
 
G

Gareth

Hi Peter,

Thanks for taking the time to run and examine my code - I really
appreciate it. I've been playing around with a few things following your
response.

You're correct with respect to not needing the events for the large
label -- but I need the events from something: they can't be userform
click events because I have the background labels for the grid which
would cover the userform and thereby block the userform's click events.
So I could use the click events of the background labels - obviously
this would have to be a new class since I don't want to write separate
events for each label - not to mention that the number of labels will
vary depending on the grid size/resolution (not necessarily an issue but
it means some juggling).

Therefore I need to trap the click events on the large form or the
background labels - I don't think it makes that much difference which
one I go for. I opted for the former for aesthetics (it lets me "sink"
the main label giving the impression of a sunken grid - which wouldn't
work for the background labels since it would appear as if each one was
sunk individually. Codewise I think it makes little difference.

I'm using multiple red labels rather than a single one that resizes with
the selection again for aesthetic reasons: I like having the little
blocks for each column - I just think it looks neater. I don't need to
trap an event of clicking on the selection - just clicks off the
selection. I'll have an "insert" button on the form which will allow the
user to replace the selection with a "proper" yellow label to represent
a record (which would be just one label no matter the width). This
wasn't clearly explained earlier - for which I apologize - but the
thrust of my query is how I get events back from a runtime addition of
the class to a form and therefore it's not really relevant.

Again, you're right: this yellow label could well be a class in its own
right. I think this is the road I shall take -- as you say, it allows me
to easily assign it new properties and indeed methods. However, I'm
still stuck with capturing the event in a class module and then having
that event fire a procedure outside the class whether it's in the grid
class or a its own discrete class - I've just moved the problem to a
different class... but I'm sure I can work around it using
application.run etc.

Thanks once again for your help,

Gareth
 
P

Peter T

Hi Gareth,

I think it would be much easier to create a collection of withevents class's
for your vertical grid labels, and a separate collection of the same class
for your red-labels.

Keep the large label at the back and make it a tad bigger for aesthetic
reasons.

Just the skeleton of what I have in mind -

'' in Userform1, Drawgrid
' make the large label bigger
With lblGrid
'size grid control as desired
.Left = GRID_START_X - 3
.Top = GRID_START_Y - 3
.Height = GRID_NO_OF_ROWS * GRID_ROW_HEIGHT + 6
.Width = GRID_NO_OF_COLS * GRID_COL_WIDTH + 6

End With

'' in class GRID

Sub FormatGridControl()
Dim iCol As Integer
Dim myLbl As MSForms.Label 'new
Dim clsLab As clsGrid2 'new
Dim id As Long 'new

'draw the back labels for the grid
For iCol = 0 To NoOfCols - 1
Set myLbl = GridParent.Controls.Add("Forms.Label.1", _
"BackDrop_Col" & iCol, True)
With myLbl
.Left = Start_X + (ColWidth * iCol)
.Width = ColWidth
.Top = Start_Y
.Height = NoOfRows * RowHeight
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 180)
.BackColor = RGB(255, 255, 255)

Set clsLab = New clsGrid2
Set clsLab.lbl = myLbl
colLbls.Add clsLab, myLbl.Name
id = id + 1
clsLab.propColID = id


' .ZOrder = 1
End With
Next iCol

'format the main label as per user settings
With Me.GridControl
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 0)
.SpecialEffect = fmSpecialEffectSunken
.BackStyle = fmBackStyleTransparent
'' keep the large label at the back so comment .ZOrder
' .ZOrder 0
End With

Set myLbl = Nothing

End Sub

'' in Module1
Public colLbls As New Collection
Public colRedLbls As New Collection

'' a new class named clsGrid2

Public WithEvents lbl As MSForms.Label
Dim nColID As Long
Dim bRedLabel As Boolean

Public Property Let propColID(n As Long)
nColID = n
End Property

Public Property Let propRed(b As Boolean)
'set this flag when adding a red label and adding
'an instance of this class to the red-labels collection
' for use in click & move events
bRedLabel = b
End Property

Private Sub lbl_Click()
If bRedLabel Then
'code
Else
'code
End If
End Sub


Private Sub lbl_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim s As String
s = nColID & " " & lbl.Name
'avoid flicker
If UserForm1.Caption <> s Then UserForm1.Caption = s

' If bRedLabel Then
'' Maybe delete a red label if moving backwards
' Else
'' stuff to add new red label and add new instance of this
'' class to the red labels collection
'' Already got nCol, Position the new red label to
'' lbl.Left, lbl.Width & height constant. Only need to calc Top from
'' this Y coord.
'' Set variables (Public in a normal module or Properties in clsGRID) to
track count and location of red labels.
'End If

End Sub

'' put this in clsGRID
'Public Property Let propMouseDown(b As Boolean)
'blnMouseButtonAlreadyDown = b
'End Property
'Public Property Get propMouseDown() As Boolean
'propMouseDown = blnMouseButtonAlreadyDown
'End Property

Private Sub lbl_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
GRID.propMouseDown = True
End Sub
Private Sub lbl_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
GRID.propMouseDown = False
End Sub

'''''''

Add new red-labels in the mousemove event in clsGrid2 with code similar but
simpler to that what you have in GridControl_MouseMove in clsGRID. Add a new
instance of the same class to the colRedLbls Collection. When creating
instances of clsGrid2 set whatever properties you need, eg columnID, what
type of label, etc.

When deleting the red-labels also Set colRedLbls = Nothing
If you want to delete the red labels from withevent code of a red-label, you
will probably need to call code in another module with OnTime Now.

Although I've suggested two public collections of clsGrid2 in a normal
module, you could instead use the GridBlocks collection you already have in
clsGRID and another similar collection in clsGRID.

I would add yet another class to handle the click event of the Textbox that
gets added. In this 3rd class set whatever properties might needed for when
user clicks to do the "main thing".

I hope you can "read my mind" as to the rest of what I envisage! However if
you can and expand on the above I think you will end up with more
flexibility, as well as easier and portable code.

Regards,
Peter T
 
G

Gareth

Hi Peter,

Wow! OK - that's probably gonna take me a minute or two :) to fully
digest. But I see where you're heading and it makes a lot of sense.

I'm going to have a play and see how I get on. I'll post back with code
when I get it running well.

That's very good of you to take the time to do this. Thanks a million.

Gareth
 
G

Gareth

Hi Peter,

I don't know whether you're still monitoring this thread, but on the
offchance you are...

I've rewritten from scratch. I've pasted my code at the bottom of this
post in order that you (or indeed anyone else) can take a look at it for
their own interest. I wouldn't expect you to read it and correct it -
it's merely a courtesy FYI.

I do have a couple of questions though:

(a) I don't understand why you placed the colLbls and colRedLbls
collections in a standard module. It would seem to me this would
preclude running two grids silmultaneously and further more they would
need clearing each time I create a new grid if I run two consecutively.
I've placed them in the clsGrid module. This way they are instantiated
along with the clsGrid. This makes more sense to me BUT... if I've
missed something glaringly obvious then please feel free to shout out!

(b) By using separate labels for each column I now lose the ability to
keep the CurrentRow property updated - which was used to track, well,
the currently selected, or at least last selected, row.
It makes sense to me (and probably you) that this is a property of the
grid (or at least the collection of label columns) rather than of an
individual label column. AFAIK there is no means within VBA of
determining that the label column is "owned" by clsGrid.
Therefore I have created a Parent property for label columns, which is
set to the creating Grid. Therefore when the grid is "Mouse Moved" I can
set and check myLabelColumn.myParent.CurrentRow. Seems to work ok.
Again - does this make sense or am I overlooking something? Is there a
better way of carrying this value from one label column to the other?
(Obviously not in a standard module since this wouldn't support multiple
grids).

Thanks again,
Gareth


To reiterate, this code is an FYI. It's far from finished and there's
no selection functionality implemented yet.

'In Userform1:
'The grid hangs off a frame control - it seems to make sense to
'let me define its approximate location and size at design time.
'So place a fairsized frame of a fairsized userform:

Dim myGrid As New clsGrid

Private Sub UserForm_Initialize()

With myGrid
.StartTime = #8:00:00 AM#
.EndTime = #7:00:00 PM#
.Resolution = #12:15:00 AM#
.RowsCount = 12
.RowsHeight = 20
Set .FrameContainer = Frame1
.CreateGrid
End With

End Sub

'----------------------------
'in clsGrid

Option Explicit

'collections
Public GridColumns As New Collection
Public GridColumnHeaders As New Collection

'define the public properties for a grid
Private GridStartTime As Date
Private GridEndTime As Date
Private GridResolution As Date
Private GridFrame As MSForms.Frame
Private RowCount As Integer
Private RowHeight As Integer

'internal properties
Private ColsPerHour As Integer
Private ColCount As Integer
Private ColWidth As Integer

Private Const TopBorderHeight As Integer = 15
Private Const LeftBorderWidth As Integer = 30

'**DEFINE PROPETIES**
'StartTime
Property Let StartTime(myStartTime As Date)
GridStartTime = myStartTime
End Property
Property Get StartTime() As Date
StartTime = GridStartTime
End Property
'EndTime
Property Let EndTime(myEndTime As Date)
GridEndTime = myEndTime
End Property
Property Get EndTime() As Date
EndTime = GridEndTime
End Property
'Resolution
Property Let Resolution(myResolution As Date)
GridResolution = myResolution
End Property
Property Get Resolution() As Date
Resolution = GridResolution
End Property
'FrameContainer
Property Set FrameContainer(myFrame As MSForms.Frame)
Set GridFrame = myFrame
End Property
Property Get FrameContainer() As MSForms.Frame
Set FrameContainer = GridFrame
End Property
'Number of Rows
Property Let RowsCount(NoOfRows As Integer)
RowCount = NoOfRows
End Property
Property Get RowsCount() As Integer
RowsCount = RowCount
End Property
'Height of Rows
Property Let RowsHeight(HeightOfRows As Integer)
RowHeight = HeightOfRows
End Property
Property Get RowsHeight() As Integer
RowsHeight = RowHeight
End Property

'Initialise our grid
Private Sub Class_Initialize()

End Sub

Sub CreateGrid()

Dim myLbl As MSForms.Label
Dim myCol As clsGridColumn
Dim iCol As Integer

'work out how many columns we have per hour
ColsPerHour = #1:00:00 AM# / GridResolution
ColCount = (GridEndTime - GridStartTime) / GridResolution

'work out the width of each column
ColWidth = (GridFrame.Width - LeftBorderWidth) / ColCount

'add the columns and column headers to the frame
With GridFrame

'now create a label for each column
For iCol = 0 To ColCount - 1
'place a new label on our frame
Set myLbl = .Controls.Add("FORMS.LABEL.1", _
fcnCreateColumnName(iCol))

'position on grid and format as necessary
With myLbl
.Top = TopBorderHeight '+ 1 - make it slightly
'under, so the top borders don't show
.Height = RowCount * RowHeight
.Left = LeftBorderWidth + (iCol * ColWidth)
.Width = ColWidth + 1
.TextAlign = fmTextAlignCenter
.BackColor = RGB(255, 255, 255)
.SpecialEffect = fmSpecialEffectRaised
'black if this is the top of the hour else grey
.BorderColor = IIf(iCol Mod ColsPerHour = 0, _
RGB(0, 0, 0), RGB(200, 200, 200))
.BorderStyle = fmBorderStyleSingle
End With

'make our new class
Set myCol = New clsGridColumn
Set myCol.GRDCOL = myLbl

Set myCol.ParentGrid = Me

'add this label to our collection
GridColumns.Add myCol, myLbl.Name

Next iCol

'create column headers - just one per hour.
For iCol = 0 To (ColCount / ColsPerHour) - 1
'place a new label on our frame
Set myLbl = .Controls.Add("FORMS.LABEL.1", "ColHeader_" & iCol)
'format as required
With myLbl
.Top = 0
.Height = TopBorderHeight + 1
.Left = LeftBorderWidth + iCol * ColWidth * ColsPerHour
.Width = ColWidth * ColsPerHour
.Caption = Format(GridStartTime + _
TimeSerial(iCol, 0, 0), "hh:nn ampm")
.TextAlign = fmTextAlignCenter
.BackColor = RGB(255, 255, 255)
.SpecialEffect = fmSpecialEffectRaised
End With

'add this label to our collection - not that we really need
GridColumnHeaders.Add myCol, myLbl.Name

Next iCol

Set myLbl = Nothing

'let's make sure we have a nice snug fit within the frame,
'we may be slightly under or over depending on the original '
'width of the frame.
.Width = LeftBorderWidth + iCol * ColWidth * ColsPerHour + 2

End With 'GridFrame


End Sub

Private Function fcnCreateColumnName(ColNo As Integer) As String
'just makes the column name - I place it in a function to make
'it easy to update the format later.
fcnCreateColumnName = "BKCol_" & Format(ColNo, "000")
End Function


'--------------------------
'In clsGridColumn

Public WithEvents GridColumn As MSForms.Label
Private myParent As clsGrid

Private CurrentRow As Integer

Property Set ParentGrid(myGrid As clsGrid)
Set myParent = myGrid
End Property
Property Get ParentGrid() As MSForms.Frame
Set ParentGrid = myParent
End Property


Private Sub GridColumn_Click()


End Sub
 
G

Gareth

And further to this...

This took me by surprise let me tell you. If you use the MouseMove event
with the mouse button down you won't get mouse move events firing for
multiple controls as you pass over them like you do without the mouse
button down. No sir. The event fires continuously until the mouse button
is released. The X/Y values continue to increment outside the boundaries
of the shape (or decrement - becoming negative) until the mouse button
is released.

It's obviously workaround-able - just requires a little calculation.
Quite unexpected though. It's actually getting more complicated than
having one big label now I think.


To see what I mean place 3 labels on a form (make label 3 pretty big)
and insert the following code:
'---------------------------
Private Sub Label1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then Label3.Caption = "label1: " & X & ", " & Y _
& vbCrLf & Label3.Caption

End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then Label3.Caption = "label2: " & X & ", " & Y _
& vbCrLf & Label3.Caption

End Sub
'---------------------------
 
P

Peter T

Hi Gareth,

I'm feeling guilty firstly for having expected you to "read my mind" (my
previous scant notes) and totally forgetting that mousemove doesn't fire
when the button is down. Or rather it does but in a different way!

re your earlier post
(a) I don't understand why you placed the colLbls and colRedLbls
collections in a standard module.
Click to expand...

- but I did also suggest putting these in your clsGrid

=====================

I shouldn't have tried to work something into your existing code. Following
rewritten from scratch but borrowing some of your code. Draws selection
labels triggered by dragging over the vertical grid labels.

A Userform, a normal module, and two class's named clsGrid & clsGrid2

Drag left or right on the grid. Click the red selection label(s)

'' Userform code
Option Explicit
Private Sub UserForm_Initialize()

With Me
.Height = 300
.Width = 500
End With
Set clsDraw.propForm = Me
clsDraw.DrawLabels
End Sub

Private Sub UserForm_Terminate()
Set clsDraw = Nothing
End Sub
'''''''''''''''''

'' in a normal module
Option Explicit

Public clsDraw As New clsGrid

Sub FormShow()
UserForm1.Show
End Sub
'''''''''''''''''''

'' code in class named "clsGrid"

Option Explicit

Private Const GRID_START_Y As Integer = 20
Private Const GRID_START_X As Integer = 50
Private Const GRID_ROW_HEIGHT As Integer = 20
Private Const GRID_COL_WIDTH As Integer = 25
' change these constants as required
Private Const GRID_NO_OF_ROWS As Integer = 10
Private Const GRID_NO_OF_COLS As Integer = 16

Dim aclsLabs(1 To GRID_NO_OF_COLS) As New clsGrid2
Dim abSelLabs(1 To GRID_NO_OF_COLS) As Boolean

Dim colGridSelection As New Collection

Dim frm As UserForm ' could just use form name
Dim nStartCol As Long
Dim nEndCol As Long
Dim bGotSelection As Boolean
Dim nRow As Long

Public Property Set propForm(uf As UserForm)
Set frm = uf
End Property
Public Property Let propLoc(ngY As Single, nC As Long)

If bGotSelection Then
nEndCol = nC
Else:
If nStartCol = 0 Then nStartCol = nC
nRow = fcnCalculateGridRowFromY(ngY)
End If
End Property
Public Property Get propLocB(nr As Long, nColSt As Long) As Long
If nStartCol < nEndCol Then
propLocB = nStartCol
nColSt = nEndCol
Else
propLocB = nEndCol
nColSt = nStartCol
End If
nr = nRow

End Property


Public Function DrawLabels()
Dim i As Long
Dim lbl As MSForms.Label


Set lbl = frm.Controls.Add("Forms.Label.1", "GRID", True)
'this label only cosmetic, no events
With lbl
.Left = GRID_START_X - 3
.Top = GRID_START_Y - 3
.Height = GRID_NO_OF_ROWS * GRID_ROW_HEIGHT + 6
.Width = GRID_NO_OF_COLS * GRID_COL_WIDTH + 6
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 0)
.SpecialEffect = fmSpecialEffectSunken
'.BackStyle = fmBackStyleTransparent
End With


For i = 1 To GRID_NO_OF_COLS
Set lbl = frm.Controls.Add("Forms.Label.1", _
"BackDrop_Col" & i, True)
With lbl
.Left = GRID_START_X + (GRID_COL_WIDTH * (i - 1))
.Width = GRID_COL_WIDTH
.Top = GRID_START_Y
.Height = GRID_NO_OF_ROWS * GRID_ROW_HEIGHT
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(0, 0, 180)
.BackColor = RGB(255, 255, 255)

Set aclsLabs(i).lbl = lbl
aclsLabs(i).propColID = i
End With
Next
End Function


Function fcnAddNewSelectionLabel(nC As Long) As Boolean
Dim myLbl As MSForms.Label
Dim iCol As Integer
Dim sName As String
Dim nStep As Long

If nStartCol > nC Then nStep = -1 Else nStep = 1

For iCol = nStartCol To nC Step nStep

sName = "R" & nRow & "C" & iCol

If Not abSelLabs(iCol) Then
Set myLbl = frm.Controls.Add("Forms.Label.1", _
sName, True)
With myLbl
.Left = GRID_START_X + (iCol - 1) * GRID_COL_WIDTH
.Top = GRID_START_Y + nRow * GRID_ROW_HEIGHT
.Height = GRID_ROW_HEIGHT
.Width = GRID_COL_WIDTH
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(200, 0, 0)
.BackColor = RGB(255, 0, 0)
End With

abSelLabs(iCol) = True

colGridSelection.Add New clsGrid2, sName
Set colGridSelection(sName).lbl = myLbl

colGridSelection(sName).propColID = iCol
colGridSelection(sName).propRed = True
bGotSelection = True

End If

Next iCol
nEndCol = iCol - nStep
sName = "Row " & nRow + 1 & " Start-Col " & nStartCol & _
" End-Col " & nEndCol
If UserForm1.Caption <> sName Then UserForm1.Caption = sName

End Function
Function fcnCalculateGridRowFromY(Y As Single) As Integer
fcnCalculateGridRowFromY = CInt(Y / GRID_ROW_HEIGHT - 0.499999)
End Function

Public Function DelSelection()
Dim i As Long
Dim s As String
If bGotSelection Then
For i = colGridSelection.Count To 1 Step -1
s = colGridSelection(i).lbl.Name
Set colGridSelection(i).lbl = Nothing
colGridSelection.Remove i
frm.Controls.Remove s
Next
Set colGridSelection = Nothing
Erase abSelLabs
End If

nStartCol = 0
nRow = 0
nEndCol = 0

bGotSelection = False
End Function
''''''''''''''''''''''''''

'' in a class named "clsGrid2"

Option Explicit
Public WithEvents lbl As MSForms.Label
Dim nColID As Long
Dim bRedLabel As Boolean
Dim Xold As Single

Public Property Let propColID(n As Long)
nColID = n
End Property
Public Property Let propRed(b As Boolean)
bRedLabel = b
End Property

Private Sub lbl_BeforeDragOver( _
ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)

If bRedLabel = False Then
clsDraw.fcnAddNewSelectionLabel nColID
End If

Cancel = True
Effect = 1

' use lbl_BeforeDropOrPaste event if need to know when/where
' dragdrop finished & button is up
End Sub

Private Sub lbl_Click()
Dim nC1 As Long, nC2 As Long, nr As Long
Dim s As String
If bRedLabel Then
nC1 = clsDraw.propLocB(nr, nC2)
s = "Row " & nr + 1 & vbCr & "Cols " & nC1 & " to " & nC2
MsgBox s
End If

End Sub

Private Sub lbl_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim MyDataObject As DataObject
Dim Effect As Integer

If Button = 1 And Not bRedLabel Then
clsDraw.DelSelection
clsDraw.propLoc(Y) = nColID

Set MyDataObject = New DataObject
'optional if needed for later
MyDataObject.SetText CStr(nColID)

Effect = MyDataObject.StartDrag
End If

End Sub


I'm not suggesting this works better than what you originally had, however I
think it's adaptable, expandable and portable.

Regards,
Peter T
 
G

Gareth

Hi Peter,

No need to feel guilty! Your code and comments were very useful and
really helped me get my head around all of this.

I really appreciate you taking the time out to tackle the problem. Your
solution is really neat - I love the way the mouse icon changes when
you select or go outside the grid. And it's compact too.

In the meantime I'd made a good start on the grid and got it behaving
pretty much as I wanted so far. I shall upgrade it later to incorporate
your suggestions.

For what it's worth I've made what I've done before seeing your new
version available at:

http://www.garhoo.com/vba/GridPlay.xls

If you fancy having a look there it will save you copying and pasting
code (I don't think there's any benefit to the NG for me to post mine
now). I wouldn't suggest for a minute you trawl through my code but if
you like you could run userform1. It finally looks like it should now -
a bit prettier now I've sized and labeled it properly although it's
still a mess. Things of note:

- Demonstrates multiple grids of differing sizes on the same form.
(No, that's not probably how I would use it in real life!! Just an
interesting exercise...)

- I've placed it in a frame now so (a) when I use it for real I can
position it on the form roughly at design time and then let it size
itself more accurately and (b) I can use it as a holder for all the
labels etc. in addition to the core grid.

- There's a few buttons to zoom in and out / expand and contract the y
axis. Just an experiment - it doesn't work that well yet. I think that's
a can of worms I might leave shut.

- You can replace a selection with a "slot" now. and then select one
of the slots. Doesn't it get exciting?

Clearly there's much to be done, it just requires a bit more work!

Once again, thanks very much for your kind help.

Gareth
 
P

Peter T

Hi Gareth,

Glad it worked and thank you for your kind comments.

A minor mod, in clsGrid2 lbl_MouseMove, could change

clsDraw.DelSelection
to
'if user holds Ctrl - extend previous selection
If Shift <> 2 Then clsDraw.DelSelection

but where to stop...

I like the demo file you uploaded. As you are setting a parent class it
occurs to me could also "RaiseEvents" from the child class to back to
parent. But that's another story.

I had a slight problem running your file in IE. Couldn't save it and closing
IE left me with an invisible instance of Excel, do doubt me missing
something obvious. Any chance you could mail (see below) a zipped copy - I
might nick some of your ideas!

Regards,
Peter T
pmbthornton gmail com


Gareth said:
Hi Peter,

No need to feel guilty! Your code and comments were very useful and
really helped me get my head around all of this.

I really appreciate you taking the time out to tackle the problem. Your
solution is really neat - I love the way the mouse icon changes when
you select or go outside the grid. And it's compact too.

In the meantime I'd made a good start on the grid and got it behaving
pretty much as I wanted so far. I shall upgrade it later to incorporate
your suggestions.

For what it's worth I've made what I've done before seeing your new
version available at:

http://www.garhoo.com/vba/GridPlay.xls

If you fancy having a look there it will save you copying and pasting
code (I don't think there's any benefit to the NG for me to post mine
now). I wouldn't suggest for a minute you trawl through my code but if
you like you could run userform1. It finally looks like it should now -
a bit prettier now I've sized and labeled it properly although it's
still a mess. Things of note:

- Demonstrates multiple grids of differing sizes on the same form.
(No, that's not probably how I would use it in real life!! Just an
interesting exercise...)

- I've placed it in a frame now so (a) when I use it for real I can
position it on the form roughly at design time and then let it size
itself more accurately and (b) I can use it as a holder for all the
labels etc. in addition to the core grid.

- There's a few buttons to zoom in and out / expand and contract the y
axis. Just an experiment - it doesn't work that well yet. I think that's
a can of worms I might leave shut.

- You can replace a selection with a "slot" now. and then select one
of the slots. Doesn't it get exciting?

Clearly there's much to be done, it just requires a bit more work!

Once again, thanks very much for your kind help.

Gareth
Click to expand...
< snip >
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

RefEdit in Class Module Problem 6
Excel Add-In to catch application events 1
Raise Event Problem 4
Private vs Public Class Modules 11
MSForms.TextBox Exit event isn't available in Excel class mosule 2
Public Variables, Class Modules and Standard Modules 2
Class Events not firing 4
Class Raise Event not firing 3

Top