OLE Automation Access example

This example shows how you might display a Milestones Professional schedule based on data in a Microsoft Access database. The same technique can be applied to other database systems.

In this case, the MS Access database includes 3 tables (table1, table2, and table3). When the Main() sub is executed (in the Milestones module), a form is presented. It is initially populated with a schedule using dates from table1. From then on, the user can press one of 3 buttons labeled "Table1", "Table2", or "Table3" and cause Milestones to change the picture which is displayed.

This is accomplished by keeping a Milestones Professional schedule object open while the MS Access application is open and closing it when the MS Access application closes. While open, when the user presses one of the button, the software will:

1		Erase any previous schedule information from the Milestones schedule and get ready for the next set of data. This is done using the DeleteCurrentPage method.

2		Open the MS Access table which corresponds to the button pressed by the user and go through it record by record to retrieve the task and manager names, Funding information and start and end dates.

3		Generate a bitmap for the first page of the schedule. After a second (timeout function called to pause), the image is shown in the user's form.

(We are not experts at MS Access programming. This example is offered to illustrate the use of Milestones Professional interface calls and give you ideas for your programming projects. This code is not complete and is not meant to be used as part of any of your projects.)

The Form:

The Access Visual Basic Program:

Public dbsCurrent As Database
Public rstTable1 As Recordset
Public numberoftasklines As Integer, numpages As Integer
Public x As Integer
Public x2 As Integer
Public TaskNumber As Integer
Public objmilestones As Object
Public StartDate As String, finishdate As String, schedulestartdate As String, schedulefinishdate As String
Public xDatediff As Long
Public title As String
Public selectedtable As String

Sub main()
DoCmd.OpenForm "form1"
'Identify the table
Set dbsCurrent = CurrentDb()

Set rstTable1 = dbsCurrent.OpenRecordset("table1", dbOpenTable)
Set objmilestones = CreateObject("Milestones")

formatmilestonesschedule
Milestones1.selectedtable = "table1"
Set Milestones1.rstTable1 = dbsCurrent.OpenRecordset("table1", dbOpenTable)
Milestones1.title = "T A B L E 1"
Milestones1.CreateSchedule

Form_Form1.showstuff

End Sub

Public Sub CreateSchedule()

schedulestartdate = "12/31/2399"
schedulefinishdate = "1/1/1100"

' this function updates the schedule using data from a table

With objmilestones
' Locate first record in selected Access table
rstTable1.MoveFirst

'check Milestones object and see if it has been used.
'are there any tasks? If so, delete and make object
'ready for new user's new table selection
numpages = .getnumberofpages
If x > 1 Then
For x = numpages To 1
.setcurrentpage x
.deletecurrentpage
Next x
Else
numberoftasklines = .getnumberoflines
If numberoftasklines > 1 Then .deletecurrentpage
End If

'color the rows differently depending upon which table is selected
For x = 0 To 2
Select Case Milestones1.selectedtable
Case "table1"
.SetScheduleGridlinesAndShades x, -1, 0, 15, 0, 4, 0
Case "table2"
.SetScheduleGridlinesAndShades x, -1, 0, 16, 0, 4, 0
Case "table3"
.SetScheduleGridlinesAndShades x, -1, 0, 17, 0, 4, 0
End Select
Next x
'Display the tasks
TaskNumber = 0
Do Until rstTable1.EOF

On Error GoTo done
'Use Milestones Etc. OLE Automation calls to add symbols to the schedule
StartDate = Format(rstTable1!StartDate, "mm/dd/yy")
'Start of loop
xDatediff = DateDiff("d", StartDate, schedulestartdate)
If xDatediff > 0 Then schedulestartdate = StartDate

finishdate = Format(rstTable1!EndDate, "mm/dd/yy")
xDatediff = DateDiff("d", finishdate, schedulefinishdate)
If xDatediff < 0 Then schedulefinishdate = finishdate
TaskNumber = TaskNumber + 1

.AddSymbol TaskNumber, StartDate, 1, 1, 2
.AddSymbol TaskNumber, finishdate, 2, 1, 2
.SetOutlineLevel TaskNumber, rstTable1!OutlineLevel
'Add information to the task columns
.PutCell TaskNumber, 1, rstTable1!Manager
.PutCell TaskNumber, 2, rstTable1!Task
.PutCell TaskNumber, 11, "$" + Str(rstTable1!Fundingyear1)
.PutCell TaskNumber, 12, "$" + Str(rstTable1!Fundingyear2)
.refreshtask TaskNumber
'Move to the next record
rstTable1.MoveNext
Loop

done:

' Put up a title and set the schedule's start and end dates
If TaskNumber > 1 Then .setlinesperpage TaskNumber
.SetTitle1 title
.SetTitle2 "Access Example"
.setlinesperpage TaskNumber
.SetStartAndEndDates schedulestartdate, schedulefinishdate
.Refresh

' Create a bitmap with the new schedule
.savebitmap "c:\milestones.bmp"

' pause to give bitmap time to save before going on
timeout
End With

Exit Sub

End Sub

Sub closeout()
'rstTable1.Close

'Keep Milestones, schedule open
'objmilestones.Close "nosave"

End Sub

Sub timeout()

Dim PauseTime, Start, Finish, TotalTime
PauseTime = 2 ' 1 second
Start = timer ' Set start time.
Do While timer < Start + PauseTime
x = 1 ' Yield to other processes.
Loop
Finish = timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
End Sub
Public Sub formatmilestonesschedule()
' FormatMilestones Schedule
' objmilestones.Activate
objmilestones.use20columns
objmilestones.setlegendheight 0#
For x = 1 To 20
objmilestones.setcolumnproperty x, "Smartcolumn", "none"
objmilestones.setcolumnproperty x, "Width", 0#
objmilestones.setcolumnproperty x, "ColumnHeadingLine1", ""
objmilestones.setcolumnproperty x, "ColumnHeadingLine2", ""
objmilestones.setcolumnproperty x, "HeadingBackgroundColor", 11
objmilestones.setcolumnproperty x, "TextAlign", 1
Next x
objmilestones.settoolboxsymbolproperty 1, "DatePosition", 13
objmilestones.settoolboxsymbolproperty 2, "DatePosition", 13
objmilestones.setcolumnproperty 1, "Width", 1#
objmilestones.setcolumnproperty 1, "ColumnHeadingLine1", "Manager"

objmilestones.setcolumnproperty 2, "Width", 1.6
objmilestones.setcolumnproperty 2, "ColumnHeadingLine1", "Task"
objmilestones.setcolumnproperty 2, "Indent", 0.2
objmilestones.setcolumnproperty 2, "TextAlign", 0

objmilestones.setcolumnproperty 11, "Width", 1
objmilestones.setcolumnproperty 11, "ColumnHeadingLine1", "Year 1"
objmilestones.setcolumnproperty 11, "ColumnHeadingLine2", "Funding"

objmilestones.setcolumnproperty 12, "Width", 1
objmilestones.setcolumnproperty 12, "ColumnHeadingLine1", "Year 2"
objmilestones.setcolumnproperty 12, "ColumnHeadingLine2", "Funding"
objmilestones.SetSummaryBarDisplay 0
End Sub

In the Form1 Module:

Option Compare Database
Private Sub Form1_Activate()
Me.Repaint
End Sub

Private Sub Command4_Click()
Milestones1.selectedtable = "table2"
rstTable1.Close

Set Milestones1.rstTable1 = dbsCurrent.OpenRecordset("table2", dbOpenTable)
Milestones1.title = "T A B L E 2"

Milestones1.CreateSchedule
Image3.Picture = "c:\milestones.bmp"
Image3.Visible = False
Image3.Visible = True
End Sub

Private Sub Command5_Click()
rstTable1.Close

Milestones1.selectedtable = "table1"
Set Milestones1.rstTable1 = dbsCurrent.OpenRecordset("table1", dbOpenTable)
Milestones1.title = "T A B L E 1"
Milestones1.CreateSchedule

Image3.Picture = "c:\milestones.bmp"
Image3.Visible = False
Image3.Visible = True

End Sub

Private Sub Command6_Click()
Milestones1.selectedtable = "table3"
rstTable1.Close

Set Milestones1.rstTable1 = dbsCurrent.OpenRecordset("table3", dbOpenTable)
Milestones1.title = "T A B L E 3"
Milestones1.CreateSchedule

Image3.Picture = "c:\milestones.bmp"
Image3.Visible = False
Image3.Visible = True
End Sub

Public Sub showstuff()
Image3.Picture = "c:\milestones.bmp"
Image3.Visible = False
Image3.Visible = True
End Sub

Private Sub Command7_Click()
Milestones1.closeout
End Sub

To try this example:

Click here to download a self-extracting EXE file containing the above code.

(This download is recommended for experienced Access users who are also experience programmers.)

For other examples, look at the Excel Example page. Anything that can be done in Excel can also be done in Access.

KIDASA Software, Inc. Website

Access Automation example #2