|
Visual Basic Scheduler Control v2.0 Sample
Code sample from the controls .bas file (intentionally incomplete and won't run by itself).
'**********
VBSchedule v2.0 for VB 3.0-6.0 **********
'******* ******
'**** Property of WolfeByte Solutions 1995-2006 ****
'**
**
'** This program is protected by and subject to all **
'** Federal copyright laws governing the duplication and
**
'** distribution of authored software. With the purchase and **
'** use of this program you agree to release WolfeByte
Solutions **
'** of all liability and/or damages as related to the use of **
'** this program and also acknowledge
that no claims or **
'** warranties regarding its usage have been offered. **
'**** ****
'******* ******
'**********
Update Version 2.0 October 3, 2002 **********
Option Explicit
'THIS RELEASE DOES NOT INCLUDE THE ABILITY TO
CREATE MULTIPLE CONTROLS!
'This may become available in a future release and will be a free upgrade.
'All subs
are in this module. To create a new control - create a new
'picturebox and place a vertical scroll bar and a label onto
it. Then copy
'the code from the demo applications following events and paste them into
'the same events in your project:
1) Form_Load 2) Scrl_Change
'3) Picture1_MouseDown, ..MouseMove and ..MouseUp. Rename any picture1
'and Scrl references
in these events to the names of your 'new controls.
'To advance the schedule to a particular date without using the
scrollbars
'use the following code: GotoValue Sch(0), Picture1(0), DateSerial(your_year, your_month, your_day) + TimeSerial(your_hour,
your_minute, your_second)
'The DefineSchedule sub contains the properties which can be changed. The
'FillResources
and FillCurrent subs contain database references (although
'the OpenDatabase line is found at the beginning of the DefineSchedule
sub).
'To connect the Access 2.0 database which is included use the Replace
'function to remove all occurances
of '*db . Then comment out lines between
'the '**Demo only' sections in the FillResources event. If you wish to use
'an
Access database other than v2.0 use the following: 1) create a database
'named schedule.mdb. 2) create a table named Items
with the following
'fields: ItemResNumber (Int), ItemResName (Str), ItemColor (Lng),
'ItemIndex (Str), ItemText (Str),
ItemDateTime (Dbl), ItemEndDateTime (Dbl).
'3) create a table named Resources with the following fields: ResName (Str),
'ResNumber (Int). The demo information is loaded in the form1_Load event.
'Make a record structure for font types
Type ftType
ftName As String
ftSize As Integer
ftBold As Integer
ftItalic As Integer
ftColor As Long
End Type
'Make a record structure for the resource list
Type ResData
ResNumber As Integer
ResName
As String
End Type
'Make a record structure for the resources that show
Type ResData2
ResNumber As Integer
ResName As String
dValue As Double
End Type
'Make a record structure for display data
Type CrnData
ResNumber As Integer
ResName As String
dIndex As String
dText As String
dColor As Long
yGrpNum As
Integer
xStart As Integer
xEnd As Integer
End Type
'Make a record structure for a schedule
Type schProps
yGroups As Integer
yGroupWidth As Integer
yGroupHeight As Integer
yGroup3D As Integer
yGroupBevel As Integer
yGroupColor As Long
yGroupInBrdr As Integer
yGroupFont1 As ftType
yGroupFont2 As ftType
yResourceWidth
As Integer
yResFont As ftType
yResShow As Integer
yResHeight As Single
yResTot As Integer
yType As Integer
yText1 As String
yText2 As String
yCrntValue As Double
yEndValue As Double
xHeight As Integer
xLargeNum
As Integer
xLargeWidth As Integer
xLarge3D As Integer
xLargeBevel As Integer
xLargeColor As Long
xLargeInBrdr
As Integer
xLargeFont1 As ftType
xLargeFont2 As ftType
xSmallNum As Integer
xSmallWidth As Integer
xType
As Integer
xText1 As String
xText2 As String
xCrntValue As Double
xCrntunit As Integer
Dis3D As Integer
DisBevel As Integer
DisColor As Long
DisInBrdr As Integer
DisBarWidth As Integer
DisBarLeft As Integer
DisFont1 As ftType
DisFont2 As ftType
DisFont3 As ftType
DisText1 As String
DisText2 As String
DisText3
As String
BackColor As Long
BackAltColor As Long
Bar3D As Integer
BarBevel As Integer
BarInrBrdr
As Integer
BarFont As ftType
BarFocus As Integer
BarFocusColor As Long
BarNewColor As Long
BarNewUnits
As Integer
BarOverlap As Integer
BarEndWidth As Integer
BarMove As Integer
GrpFocus As Integer
End
Type
'Create Schedule array
Global Sch(0) As schProps
'Create resource array
Dim yResList() As ResData
Dim yResCrnt() As ResData2
Const ListEnd = -32768
'Create data array for display data
Dim CrntData()
As CrnData
Global p1% 'Will be set to the twipsperpixel * 1
Global p2% 'Will be set to the twipsperpixel * 2
Global
p3% 'Will be set to the twipsperpixel * 3
Global tmpMouse As Integer
Global tmpPos As Integer
Global db As
Database
Global ds As Dynaset
Sub DefineSchedule0(inPct As PictureBox, Scrl As Control)
'This sub
needs to be called once from the form load event so that the
'Schedule(0) is assigned its properties.
'Properties
for Schedule(0)
'*db Set db = OpenDatabase("schedule.mdb") 'Open database
inPct.AutoRedraw = True 'Allow creation
of picturebox in memory
inPct.ScaleMode = 1 'Set the picturebox scale to twips
p1 = Screen.TwipsPerPixelX 'This is
how wide one drawing line will be - used for bevels and some line drawing
p2 = p1 * 2 'Width of two lines
p3 = p1
* 3 'Width of three lines (add more if needed)
Sch(0).xHeight = 50 * p1 'Height of x axis display area
'yType
is how you want the vertical values to be grouped/presented.
'xType is how you want the horizontal values to be grouped/presented.
'The xType MUST BE 1 category less than the yType. The xType can be
'subdivided by setting the xSmallNum value below
(i.e. xType=2 would
'show hour groups and xSmallNum=4 would subdivide them into 15 min. parts).
'Make sure that you
match the xText/yText formats according to the type.
'To advance the schedule to a particular date without using the
scrollbars
'use the following code: GotoValue Sch(0), Picture1(0), DateSerial(your_year, your_month, your_day) + TimeSerial(your_hour,
your_minute, your_second)
Sch(0).yType = 3 '1-m,2-h,3-d,4-m
Sch(0).xType = 2 '0-s,1-m,2-h,3-d
Sch(0).xText1
= "~h:00" 'Leave blank to use only one line of text
Sch(0).xText2 = "" 'Use ~ for formatting otherwise only string will
print
Sch(0).yGroups = 7 '0 shows resources only and >0 shows y axis groups (value of 1 doesn't offer very much
- use 0 or >1 instead)
If Sch(0).yGroups Then
Sch(0).yText1 = "~ddd" 'Make sure that these formats match the yType
Sch(0).yText2 = "~d"
Sch(0).yGroupWidth = 55 * p1 'Width of y axis groups
Sch(0).yGroupHeight = (inPct.ScaleHeight
- Sch(0).xHeight) / Sch(0).yGroups 'Do Not Change
Sch(0).yGroup3D = 1
Sch(0).yGroupBevel = p2
Sch(0).yGroupColor
= QBColor(13)
Sch(0).yGroupInBrdr = True
Sch(0).yGroupFont1.ftName = "MS Sans Serif" 'Two text lines can show
Sch(0).yGroupFont1.ftSize
= 8.25 'yText is above
Sch(0).yGroupFont1.ftBold = True
Sch(0).yGroupFont1.ftItalic = True
Sch(0).yGroupFont1.ftColor
= 0
Sch(0).yGroupFont2.ftName = "MS Sans Serif"
Sch(0).yGroupFont2.ftSize = 8.25
Sch(0).yGroupFont2.ftBold = False
Sch(0).yGroupFont2.ftItalic = False
Sch(0).yGroupFont2.ftColor = 0
Else
Sch(0).yGroupWidth = 0 'If no groups
then width must be 0
Sch(0).yGroupHeight = inPct.ScaleHeight - Sch(0).xHeight 'Do Not Change
End If
Dim gr%
If Sch(0).yGroups > 1 Then 'Next lines will set the start/end values
gr = Sch(0).yGroups
Else
gr = 2
End
If
Sch(0).yCrntValue = SetStartEnd(Sch(0), DateSerial(Year(Now), Month(Now), Day(Now)), 0) 'Starting value of the y axis
Sch(0).yEndValue = SetStartEnd(Sch(0), DateSerial(Year(Now), Month(Now), Day(Now)), gr) 'Ending value of the y axis -
used in the FillCurrent
Sch(0).yResourceWidth = 75 * p1 'Width of the resource area
Sch(0).yResFont.ftName = "MS
Sans Serif" 'Resource font info
Sch(0).yResFont.ftSize = 8.25
Sch(0).yResFont.ftBold = False
Sch(0).yResFont.ftItalic
= False
Sch(0).yResFont.ftColor = 0
Sch(0).xLargeNum = 10 'How many x axis group will show
Sch(0).xLargeWidth
= (inPct.ScaleWidth - Sch(0).yResourceWidth - Sch(0).yGroupWidth) / Sch(0).xLargeNum 'Do Not Change
Sch(0).xLarge3D =
1
Sch(0).xLargeBevel = p2
Sch(0).xLargeColor = QBColor(14)
Sch(0).xLargeInBrdr = True
Sch(0).xLargeFont1.ftName
= "MS Sans Serif" 'Two lines of text can show
Sch(0).xLargeFont1.ftSize = 8.25 'xText is above
Sch(0).xLargeFont1.ftBold
= True
Sch(0).xLargeFont1.ftItalic = True
Sch(0).xLargeFont1.ftColor = 0
Sch(0).xLargeFont2.ftName = "MS Sans
Serif"
Sch(0).xLargeFont2.ftSize = 8.25
Sch(0).xLargeFont2.ftBold = False
Sch(0).xLargeFont2.ftItalic = False
Sch(0).xLargeFont2.ftColor = 0
Sch(0).xSmallNum = 4 'Cannot be 0 - will subdivide the xType grouping. MUST BE
1 if xType=0 - cant go subdivide second here.
Sch(0).xSmallWidth = (inPct.ScaleWidth - Sch(0).yResourceWidth - Sch(0).yGroupWidth)
/ (Sch(0).xLargeNum * Sch(0).xSmallNum) 'Do Not Change
Sch(0).xCrntValue = DateSerial(Year(Now), Month(Now), Day(Now))
+ TimeSerial(Hour(Now), 0, 0) 'This the the starting value of the x axis. Actual value may be adjusted in the DrawXText sub
Sch(0).Dis3D = 1 'These settings are for the Display area on the
Sch(0).DisBevel = p2 'top left of the schedule
area
Sch(0).DisColor = QBColor(2)
Sch(0).DisInBrdr = True
Sch(0).DisBarWidth = 10 * p1 'Width of display area
scroll bars
Sch(0).DisBarLeft = 70 * p1 'Left position of left-most scroll bar
Sch(0).DisFont1.ftName = "MS Sans
Serif" 'Top line of display text
Sch(0).DisFont1.ftSize = 8.25
Sch(0).DisFont1.ftBold = True
Sch(0).DisFont1.ftItalic
= True
Sch(0).DisFont1.ftColor = 0
Sch(0).DisFont2.ftName = "MS Sans Serif" '2nd line of display text
Sch(0).DisFont2.ftSize
= 8.25
Sch(0).DisFont2.ftBold = False
Sch(0).DisFont2.ftItalic = False
Sch(0).DisFont2.ftColor = 0
Sch(0).DisFont3.ftName
= "MS Sans Serif" 'Right most display text
Sch(0).DisFont3.ftSize = 8.25
Sch(0).DisFont3.ftBold = True
Sch(0).DisFont3.ftItalic
= True
Sch(0).DisFont3.ftColor = QBColor(15)
Sch(0).DisText1 = "Week" 'Can be formatted using ~ or text only
Sch(0).DisText2
= "~m/d/yy" 'without the ~ being used.
Sch(0).DisText3 = "Hour" 'Dont use any formatting
Sch(0).BackColor = QBColor(7)
'Backcolor of schedule grid area
Sch(0).BackAltColor = QBColor(15) 'Alternate color (set same as above if not wanted)
Sch(0).Bar3D = 1 'Item bars properties
Sch(0).BarBevel = p2
Sch(0).BarInrBrdr = True
Sch(0).BarFont.ftName
= "MS Sans Serif"
Sch(0).BarFont.ftSize = 8.25
Sch(0).BarFont.ftBold = False
Sch(0).BarFont.ftItalic = False
Sch(0).BarFocus
= ListEnd 'No bar has focus when started
Sch(0).BarFocusColor = QBColor(15)
Sch(0).BarNewColor = QBColor(10)
Sch(0).BarNewUnits
= 6
Sch(0).BarOverlap = False
Sch(0).BarEndWidth = p2 + p3 'How much of the left/right ends of an item be for resizing
Sch(0).GrpFocus = ListEnd 'No group has focus when started
'Move the display scroll bars
Scrl.Parent.Scrl(0).Move
Sch(0).DisBarLeft, Sch(0).DisBevel + p1, Sch(0).DisBarWidth, Sch(0).xHeight - (Sch(0).DisBevel * 2) - p1
Scrl.Parent.Scrl(0).Visible
= True
Scrl.Parent.Scrl(0).Tag = inPct.Index 'Do Not change or use the tag property of the scroll bars - needed in the
scroll click event
Load Scrl.Parent.Scrl(1)
Scrl.Parent.Scrl(1).Move Sch(0).yGroupWidth + Sch(0).yResourceWidth
- Sch(0).DisBevel - Sch(0).DisBarWidth, Sch(0).DisBevel + p1, Sch(0).DisBarWidth, Sch(0).xHeight - (Sch(0).DisBevel * 2) -
p1
Scrl.Parent.Scrl(1).Visible = True
Scrl.Parent.Scrl(1).Tag = inPct.Index 'Do Not change or use the tag property
of the scroll bars - needed in the scroll click event
'Fill the resource lists and set each scroll bar accordingly
FillResources Sch(0), inPct
SetScrolls Sch(0), inPct, Scrl
'Draw the schedule
DrawSchedule Sch(0), inPct
End Sub
Sub AddModDelItem(Act%, Idx%, C%, inPct As PictureBox, x%, y%, Z%)
Dim n%, i%, sd#, st#
'All adds, deletes and modifies to the CrntArray and are in this sub. Calls
'to database actions (DbAddModDel)
also occur in this sub.
Select Case Act
Case 1 'Add new item
n = UBound(CrntData) + 1
ReDim Preserve CrntData(n)
Sch(Idx).BarFocus = n
CrntData(n).ResNumber = yResCrnt(y).ResNumber
CrntData(n).ResName = yResCrnt(y).ResName
'** Bar color and/or bar text could be asked for/input here
CrntData(n).dColor = Sch(Idx).BarNewColor
CrntData(n).dText
= "Text" & x
CrntData(n).yGrpNum = Z
CrntData(n).xStart = x + Sch(Idx).xCrntunit
CrntData(n).xEnd = x
+ Sch(Idx).xCrntunit + Sch(Idx).BarNewUnits - 1
sd = ConvToValue(Sch(Idx), CrntData(C).yGrpNum, 0) 'calc start date
st = ConvToValue(Sch(Idx), CrntData(C).xStart, 1) 'calc start time
sd = sd + st
'dIndex will be used for database
findfirst actions (delete and modify)
CrntData(n).dIndex = Year(sd) & Month(sd) & Day(sd) & Hour(sd) &
Minute(sd) & Second(sd) & CrntData(n).ResNumber
If Sch(Idx).GrpFocus <> ListEnd Then 'clear focus on
any previous bar
DrawData Sch(Idx), inPct, Sch(Idx).GrpFocus
End If
Sch(Idx).GrpFocus = Z
DrawData Sch(Idx),
inPct, CrntData(n).yGrpNum 'redraw items group
'add to database
DbAddModDel Act, n, Idx
'make new item current
record
DbAddModDel 4, n, Idx
Case 2 'Delete existing item
Sch(Idx).BarFocus = ListEnd
CrntData(C).ResNumber
= ListEnd 'clear all array elements here
CrntData(C).ResName = ""
CrntData(C).dColor = 0
CrntData(C).dText = ""
CrntData(C).xStart = ListEnd
CrntData(C).xEnd = ListEnd
Sch(Idx).GrpFocus = ListEnd
DrawGridV Sch(Idx),
inPct, CrntData(C).yGrpNum 'clear items group first
DrawData Sch(Idx), inPct, CrntData(C).yGrpNum 'redraw items group
'delete from database - wont use any find item after
DbAddModDel Act, C, Idx
Case 3 'Modify existing item
Dim botY%, resY%, difY%, s%, e%, t%, tmp%, tmp2%
y = y - Sch(Idx).xHeight 'top of grid
Z = y \ Sch(Idx).yGroupHeight
'which group #
botY = Z * Sch(Idx).yGroupHeight 'y value of group start
resY = Sch(Idx).yResHeight * Sch(Idx).yResShow
'total resources height
difY = (((Z + 1) * Sch(Idx).yGroupHeight) - botY) - resY 'unused group area
If y >=
botY And y < resY + botY Then 'is y pointing to a resource - no actions otherwise
y = ((y - (difY * Z)) \ Sch(Idx).yResHeight)
Else
y = -1
End If
x = x - Sch(Idx).yResourceWidth - Sch(Idx).yGroupWidth 'x position of left side of
grid
x = (x \ Sch(Idx).xSmallWidth) 'which x unit is being pointed to
t = Sch(Idx).xLargeNum * Sch(Idx).xSmallNum
'total number of units on grid area
If Sch(Idx).yGroups = 0 Then 'calc true y position based on sch type
tmp2
= y
Else
tmp2 = (Sch(Idx).yGroups * Sch(Idx).yResShow) - 1
End If
If (x >= 0) And (y >= 0 And y
<= tmp2) Then 'dont do anything if mouse not in valid area
C = Sch(Idx).BarFocus 'pointer to current array item
s
= CrntData(C).xStart - Sch(Idx).xCrntunit 'item start unit
e = CrntData(C).xEnd - Sch(Idx).xCrntunit + 1 'item end unit
Select Case tmpMouse 'what kind of modification is happening
Case 5 'center - whole item move
If Sch(Idx).BarOverlap
= False Then 'check for overlapping of existing items
For i = 0 To UBound(CrntData)
If CrntData(i).yGrpNum = Z And
CrntData(i).ResNumber = yResCrnt(y).ResNumber And i <> C Then
'overlap whole items
If (CrntData(i).xStart >=
x + Sch(Idx).xCrntunit - tmpPos And CrntData(i).xEnd <= x + Sch(Idx).xCrntunit - tmpPos + (e - s) - 1) Or (CrntData(i).xStart
<= x + Sch(Idx).xCrntunit - tmpPos And CrntData(i).xEnd >= x + Sch(Idx).xCrntunit - tmpPos + (e - s) - 1) Then
MsgBox
"Move would overlap an existing item.", 0, "Cannot Overlap Items"
Sch(Idx).BarMove = False
tmpMouse = 0
Screen.MousePointer
= 0
Exit Sub
End If
'overlap on left side
If x + Sch(Idx).xCrntunit - tmpPos <= CrntData(i).xEnd And x
+ Sch(Idx).xCrntunit - tmpPos >= CrntData(i).xStart Then
MsgBox "Move would overlap an existing item.", 0, "Cannot
Overlap Items"
Sch(Idx).BarMove = False
tmpMouse = 0
Screen.MousePointer = 0
Exit Sub
End If
'overlap
on right side
If x + Sch(Idx).xCrntunit - tmpPos + (e - s) - 1 >= CrntData(i).xStart And x + Sch(Idx).xCrntunit - tmpPos
+ (e - s) - 1 <= CrntData(i).xEnd Then
MsgBox "Move would overlap an existing item.", 0, "Cannot Overlap Items"
Sch(Idx).BarMove
= False
tmpMouse = 0
Screen.MousePointer = 0
Exit Sub
End If
End If
Next
End If
'store previous
group (if different than new group)
If Z <> CrntData(C).yGrpNum Then
tmp = CrntData(C).yGrpNum
End If
CrntData(C).ResNumber
= yResCrnt(y).ResNumber
CrntData(C).ResName = yResCrnt(y).ResName
CrntData(C).yGrpNum = Z
CrntData(C).xStart =
x + Sch(Idx).xCrntunit - tmpPos
CrntData(C).xEnd = CrntData(C).xStart + (e - s) - 1
'redraw previous group (if different
than new group)
DrawGridV Sch(Idx), inPct, tmp 'clear items group first
DrawData Sch(Idx), inPct, tmp 'redraw items
group
Case 8 'left end move
'dont allow changes if mouse is off from current bar or move is past right end of
item
If yResCrnt(y).ResNumber = CrntData(C).ResNumber And Z = CrntData(C).yGrpNum Then
If x + Sch(Idx).xCrntunit <=
CrntData(C).xEnd Then
If Sch(Idx).BarOverlap = False Then 'check for overlapping
For i = 0 To UBound(CrntData)
If
CrntData(i).yGrpNum = Z And CrntData(i).ResNumber = yResCrnt(y).ResNumber And i <> C Then
If CrntData(i).xEnd <
CrntData(C).xEnd Then
If CrntData(i).xEnd >= x + Sch(Idx).xCrntunit Or x + Sch(Idx).xCrntunit <= CrntData(i).xStart
Then
MsgBox "Move would overlap an existing item.", 0, "Cannot Overlap Items"
Sch(Idx).BarMove = False
tmpMouse
= 0
Screen.MousePointer = 0
Exit Sub
End If
End If
End If
Next
End If
CrntData(C).xStart =
x + Sch(Idx).xCrntunit
End If
End If
Case 9 'right end move
'dont allow changes if mouse is off from current
bar or move is past left end of item
If yResCrnt(y).ResNumber = CrntData(C).ResNumber And Z = CrntData(C).yGrpNum Then
If x + Sch(Idx).xCrntunit >= CrntData(C).xStart And x < t Then
If Sch(Idx).BarOverlap = False Then 'check for
overlap
For i = 0 To UBound(CrntData)
If CrntData(i).yGrpNum = Z And CrntData(i).ResNumber = yResCrnt(y).ResNumber
And i <> C Then
If CrntData(i).xStart > CrntData(C).xEnd Then
If CrntData(i).xStart <= x + Sch(Idx).xCrntunit
Or x + Sch(Idx).xCrntunit >= CrntData(i).xEnd Then
MsgBox "Move would overlap an existing item.", 0, "Cannot Overlap
Items"
Sch(Idx).BarMove = False
tmpMouse = 0
Screen.MousePointer = 0
Exit Sub
End If
End If
End
If
Next
End If
CrntData(C).xEnd = x + Sch(Idx).xCrntunit
End If
End If
End Select
'modify item
in database
DbAddModDel Act, C, Idx
'make the item the current record
DbAddModDel 4, C, Idx
End If
Sch(Idx).BarMove
= False
tmpMouse = 0
Screen.MousePointer = 0
DrawGridV Sch(Idx), inPct, CrntData(C).yGrpNum 'clear items group
first
DrawData Sch(Idx), inPct, CrntData(C).yGrpNum 'redraw items group
End Select
End Sub
|
