|
-
Sep 23rd, 2022, 09:06 AM
#5
Addicted Member
Re: Grid-like Userform
Here's one option. The code below:
- dynamically creates 100 label controls (10 x 10);
- creates a transparent 'Overlay' label control that is used to track the mouse location over the entire matrix/grid;
- it calculates which label control (or "tile") it is currently hovering over; and
- on the MouseDown event, it changes that tile's backcolor to either being teal or the original backcolor of the userform depending on the tile's On/Off state (saved in a 1D array).

Code:
Private WithEvents Overlay As MSForms.Label
Private SelectedTiles(1 To 100) As Boolean
Private ClickAndDraw As Boolean
Private CurrentTile As Long
Private Const TOTALTILESHIGH As Long = 10
Private Const TOTALTILESWIDE As Long = 10
Private Const TILEWIDTH As Long = 30
Private Const TILEHEIGHT As Long = 30
Private Const XOFFSET As Long = 20
Private Const YOFFSET As Long = 20
' CREATE 100 LABEL CONTROLS, CENTRE THE CAPTION, CREATE OVERLAY LABEL CONTROL
Private Sub UserForm_Activate()
DrawGrid
DrawOverlay
End Sub
Sub DrawGrid()
For Y = 1 To TOTALTILESHIGH
For X = 1 To TOTALTILESWIDE
Counter = Counter + 1
Set Ctrl = Me.Controls.Add("Forms.Label.1", "Control" & Format(Counter, "000"))
With Ctrl
.Caption = Counter
.Font.Size = 12
.TextAlign = fmTextAlignCenter
.BackColor = Me.BackColor
.BorderStyle = fmBorderStyleNone
.Left = XOFFSET + (X * TILEWIDTH) - TILEWIDTH
.Top = YOFFSET + (Y * TILEHEIGHT) - TILEHEIGHT
.Width = TILEWIDTH
.Height = TILEHEIGHT
.ForeColor = RGB(140, 140, 140)
End With
CenterLabelText Ctrl
Next
Next
End Sub
Sub DrawOverlay()
Set Overlay = Me.Controls.Add("Forms.Label.1", "OVERLAY")
With Overlay
.Left = Me.Controls("Control001").Left
.Top = Me.Controls("Control001").Top
.Width = TOTALTILESWIDE * TILEWIDTH
.Height = TOTALTILESHIGH * TILEHEIGHT
.Caption = ""
.BackStyle = fmBackStyleTransparent
End With
End Sub
Sub CenterLabelText(ByVal LabelCtrl As MSForms.Label, Optional bCenter As Boolean = True)
'https://www.mrexcel.com/board/threads/autofit-alignment-for-the-word-inside-label-on-userform-to-equal-distance-up-down.1205039/
If Len(LabelCtrl.Caption) = 0 Then Err.Raise Number:=vbObjectError + 513, Description:=LabelCtrl.Name & " has no Caption."
LabelCtrl.Picture = IIf(bCenter, New stdole.StdPicture, Nothing)
End Sub
' CALCULATE TILENUMBER UNDER THE MOUSE CURSOR
Sub GetCoordinates(ByVal X As Long, ByVal Y As Long, Optional ByRef TileX As Long, Optional ByRef TileY As Long, Optional ByRef TileNumber As Long)
TileX = Application.Ceiling(X, TILEWIDTH) / TILEWIDTH
TileY = Application.Ceiling(Y, TILEHEIGHT) / TILEHEIGHT
TileNumber = TileY * TOTALTILESHIGH - TOTALTILESHIGH + TileX
End Sub
' PAINT TILES
Sub ToggleAndPaint(TileNumber As Long)
If SelectedTiles(TileNumber) Then
SelectedTiles(TileNumber) = Not (SelectedTiles(TileNumber))
Me.Controls("Control" & Format(TileNumber, "000")).BackColor = Me.BackColor
Me.Controls("Control" & Format(TileNumber, "000")).ForeColor = RGB(140, 140, 140)
Else
Me.Controls("Control" & Format(TileNumber, "000")).BackColor = RGB(0, 120, 120)
Me.Controls("Control" & Format(TileNumber, "000")).ForeColor = vbWhite
SelectedTiles(TileNumber) = True
End If
End Sub
' OVERLAY - EVENTS
Private Sub Overlay_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ClickAndDraw = True
End Sub
Private Sub Overlay_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim TileNumber As Long
GetCoordinates X, Y, , , TileNumber
If CurrentTile = TileNumber Or TileNumber > TOTALTILESHIGH * TOTALTILESWIDE Then Exit Sub
Me.Caption = "Hovering over tile#" & TileNumber
If ClickAndDraw Then
ToggleAndPaint TileNumber
CurrentTile = TileNumber
End If
End Sub
Private Sub Overlay_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim TileNumber As Long
GetCoordinates X, Y, , , TileNumber
ClickAndDraw = False
If CurrentTile = TileNumber Or TileNumber > TOTALTILESHIGH * TOTALTILESWIDE Then Exit Sub
ToggleAndPaint TileNumber
End Sub
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|