GFCheckField/GFCheckField.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "GFCheckField"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4680
StartUpPosition = 3 'Windows‑Standard
Begin VB.PictureBox GFCheckFieldPicture
BackColor = &H00000000&
BorderStyle = 0 'Kein
Enabled = 0 'False
Height = 795
Left = 60
ScaleHeight = 795
ScaleWidth = 4575
TabIndex = 2
Top = 840
Visible = 0 'False
Width = 4575
Begin VB.CheckBox GFCheckFieldCheck
Caption = "GFCheckFieldCheck"
Enabled = 0 'False
Height = 255
Index = 0
Left = 0
TabIndex = 3
Top = 0
Visible = 0 'False
Width = 1875
End
End
Begin VB.CommandButton Command2
Caption = "Command2"
Height = 315
Left = 1140
TabIndex = 1
Top = 2820
Width = 1695
End
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 315
Left = 2880
TabIndex = 0
Top = 2820
Width = 1695
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)? by Louis.
'GFCheckField
Private Type GFCheckFieldStruct
CheckFieldCheckNumber As Integer
CheckFieldCheckCheckedNumberOld As Integer
CheckFieldCreatedFlag As Boolean
End Type
Dim GFCheckFieldStructVar As GFCheckFieldStruct
Private Sub Command1_Click()
Debug.Print GFCheckField_Create(3, 0, 0, 640, 150, True, 0, RGB(150, 150, 150), RGB(50, 250, 50), "string ##")
End Sub
Private Sub Command2_Click()
Dim Temp As Long
For Temp = 1 To GFCheckFieldStructVar.CheckFieldCheckNumber
Debug.Print GFCheckField_GetValue(Temp)
Next Temp
End Sub
'*************************************GFCHECKFIELD**************************************
'NOTE: use GFCheckField_Create() to create an 'optical field' that contains a defined
'number of check boxes. The user can enable/disable one check box by
'left‑/right‑clicking on it, or enable/disable all check boxes by clicking into the picture box.
'Pay attention that the size of the check boxes matches that of the text they will contain and
'that the z‑order of the controls is correct (check boxes must be on top).
'The last '#' in check box text will be replaced with check box index.
Private Function GFCheckField_Create(ByVal CheckFieldCheckNumber As Integer, ByVal CheckFieldXPos As Long, ByVal CheckFieldYPos As Long, ByVal CheckFieldWidth As Long, ByVal CheckFieldHeight As Long, ByVal CheckFieldHOrVFlag As Boolean, ByVal CheckFieldPictureBackColor As Long, ByVal CheckFieldCheckBackColor As Long, ByVal CheckFieldCheckFontColor As Long, ByVal CheckFieldCheckTextString As String)
'on error resume next
Dim Temp As Long
'verify
If (CheckFieldCheckNumber < 1) Or (CheckFieldWidth < 1) Or (CheckFieldHeight < 1) Or _
(GFCheckFieldStructVar.CheckFieldCreatedFlag = True) Then 'verify
GFCheckField_Create = False 'error
Exit Function
End If
GFCheckFieldStructVar.CheckFieldCreatedFlag = True
'initialize GFCheckFieldPicture
GFCheckFieldPicture.Left = CheckFieldXPos * Screen.TwipsPerPixelX
GFCheckFieldPicture.Top = CheckFieldYPos * Screen.TwipsPerPixelY
GFCheckFieldPicture.Width = CheckFieldWidth * Screen.TwipsPerPixelX
GFCheckFieldPicture.Height = CheckFieldHeight * Screen.TwipsPerPixelY
GFCheckFieldPicture.BackColor = CheckFieldPictureBackColor
GFCheckFieldPicture.Enabled = True
GFCheckFieldPicture.Visible = True
'initialize GFCheckFieldCheck
GFCheckFieldStructVar.CheckFieldCheckNumber = CheckFieldCheckNumber
GFCheckFieldCheck(0).TabStop = False 'no tab stop
GFCheckFieldCheck(0).ForeColor = CheckFieldCheckFontColor
GFCheckFieldCheck(0).BackColor = CheckFieldCheckBackColor
For Temp = 1 To GFCheckFieldStructVar.CheckFieldCheckNumber
If Not ((Temp ‑ 1) = 0) Then Load GFCheckFieldCheck(Temp ‑ 1)
Select Case CheckFieldHOrVFlag
Case True 'horizontal
GFCheckFieldCheck(Temp ‑ 1).Left = ((CheckFieldWidth / GFCheckFieldStructVar.CheckFieldCheckNumber) * (Temp ‑ 1)) * Screen.TwipsPerPixelX + _
((CheckFieldWidth / GFCheckFieldStructVar.CheckFieldCheckNumber * 0.5! * Screen.TwipsPerPixelX)) ‑ _
(GFCheckFieldCheck(Temp ‑ 1).Width * 0.5!)
GFCheckFieldCheck(Temp ‑ 1).Top = ((CSng(CheckFieldHeight) ‑ CSng(GFCheckFieldCheck(Temp ‑ 1).Height / Screen.TwipsPerPixelY)) * 0.5! * Screen.TwipsPerPixelY)
Case False 'vertical
GFCheckFieldCheck(Temp ‑ 1).Top = ((CheckFieldHeight / GFCheckFieldStructVar.CheckFieldCheckNumber) * (Temp ‑ 1)) * Screen.TwipsPerPixelY + _
(CSng((CheckFieldHeight / GFCheckFieldStructVar.CheckFieldCheckNumber)) * 0.5! * CSng(Screen.TwipsPerPixelY)) ‑ _
(GFCheckFieldCheck(Temp ‑ 1).Height * 0.5!)
GFCheckFieldCheck(Temp ‑ 1).Left = ((CSng(CheckFieldWidth) ‑ CSng(GFCheckFieldCheck(Temp ‑ 1).Width / Screen.TwipsPerPixelX)) * 0.5! * Screen.TwipsPerPixelX)
End Select
Next Temp
For Temp = 1 To GFCheckFieldStructVar.CheckFieldCheckNumber
GFCheckFieldCheck(Temp ‑ 1).Caption = GFCheckFieldCheck_GetText(CheckFieldCheckTextString, Temp)
GFCheckFieldCheck(Temp ‑ 1).Enabled = True
GFCheckFieldCheck(Temp ‑ 1).Visible = True
Next Temp
GFCheckField_Create = True 'ok
Exit Function
End Function
Private Function GFCheckFieldCheck_GetText(ByVal CheckFieldCheckTextString As String, ByVal CheckFieldCheckIndex As Integer) As String
'on error resume next 'replaces last '#' with LTrim$(Str$(CheckFieldCheckIndex))
Dim Temp As Long
For Temp = Len(CheckFieldCheckTextString) To 1 Step (‑1)
If Mid$(CheckFieldCheckTextString, Temp, 1) = "#" Then
GFCheckFieldCheck_GetText = Left$(CheckFieldCheckTextString, Temp ‑ 1) + LTrim$(Str$(CheckFieldCheckIndex)) + Right$(CheckFieldCheckTextString, Len(CheckFieldCheckTextString) ‑ Temp)
Exit Function
End If
Next Temp
GFCheckFieldCheck_GetText = CheckFieldCheckTextString
Exit Function
End Function
Private Sub GFCheckFieldCheck_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next 'set value of one check box
Select Case Button
Case vbLeftButton
GFCheckFieldCheck(Index).Value = 1
Case vbRightButton
GFCheckFieldCheck(Index).Value = 0
End Select
If GFCheckField_CheckForChange = True Then Call GFCheckField_Change
End Sub
Private Sub GFCheckFieldPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next 'set value of all check boxes
Dim Temp As Long
Select Case Button
Case vbLeftButton
For Temp = 1 To GFCheckFieldStructVar.CheckFieldCheckNumber
GFCheckFieldCheck(Temp ‑ 1).Value = 1
Next Temp
Case vbRightButton
For Temp = 1 To GFCheckFieldStructVar.CheckFieldCheckNumber
GFCheckFieldCheck(Temp ‑ 1).Value = 0
Next Temp
End Select
If GFCheckField_CheckForChange = True Then Call GFCheckField_Change
End Sub
Private Function GFCheckField_CheckForChange() As Boolean
'on error resume next 'returns True if number of checked check boxes has changed since last call of this funtion, False if not
Dim CheckFieldCheckCheckedNumber As Integer
Dim Temp As Long
'begin
For Temp = 1 To GFCheckFieldStructVar.CheckFieldCheckNumber
If GFCheckField_GetValue(Temp) = True Then
CheckFieldCheckCheckedNumber = CheckFieldCheckCheckedNumber + 1
End If
Next Temp
If Not (CheckFieldCheckCheckedNumber = GFCheckFieldStructVar.CheckFieldCheckCheckedNumberOld) Then
GFCheckField_CheckForChange = True
Else
GFCheckField_CheckForChange = False
End If
GFCheckFieldStructVar.CheckFieldCheckCheckedNumberOld = CheckFieldCheckCheckedNumber
End Function
Private Function GFCheckField_GetValue(ByVal CheckFieldCheckIndex As Integer) As Boolean
'on error resume next 'returns True if check box is checked, False if not
If (CheckFieldCheckIndex < 1) Or (CheckFieldCheckIndex > GFCheckFieldStructVar.CheckFieldCheckNumber) Then
MsgBox "internal error in GFCheckField_GetValue(): passed value invalid !", vbOKOnly + vbExclamation
End If
Select Case GFCheckFieldCheck(CheckFieldCheckIndex ‑ 1).Value
Case 0
GFCheckField_GetValue = False
Case 1
GFCheckField_GetValue = True
Case 2
GFCheckField_GetValue = True
End Select
End Function
Private Sub GFCheckField_Change()
'on error resume next 'callback sub; called when at least one check box value was changed
'***SUB CALLLED ON CHECK FIELD CHANGE***
Debug.Print "Changed" 'DEBUG
'***END***
End Sub
'**********************************END OF GFCHECKFIELD**********************************
[END OF FILE]