Hi Experts!
I"m working on a database calendar and its output is exported in a Excel file. The only problem that I have is the query I made, I have not found a particular way to insert it in the module. The query has to be able to select only GE and BOTH statements for the export. When it's for a BY event, in the export there will be only BY and BOTH statements without GE statements.
There's the query
SELECT TblCalendar.StatID, TblCalendar.Activity, TblCalendar.Calendar_E, TblCalendar.Calendar_F, TblCalendar.EventDay, TblCalendar.DirectorateID,
TblCalendar.Rel_Link, TblCalendar.EMSQCode, TblCalendar.StatReq, TblCalendar.Stat_Applic, TblCalendar.EMS_Item
FROM TblCalendar
WHERE (((TblCalendar.Stat_Applic
)="GE")) OR (((TblCalendar.Stat_Applic
)="BOTH"))
;
The export code:
Public Sub Export_with_Dates(MyCal As Integer, MyLang$)
'-----start code and comments:
'MyCal is which calendar we want (36, 45 ,55)
'MyLang is E for English, F for French
'parameters are passed via the switchboard form
'with some "helper subroutines" to pass the parameters
Dim Db As DAO.Database
Dim rs_weeks As DAO.Recordset, rs_data As DAO.Recordset, rs_statements As DAO.Recordset
Dim appexcel As Object 'Excel.Application
Dim a$
Dim xlPath As String
'xlPath = CurrentProject.Path & "\Calendar Template (tied to code)\EMS Calendar Excel.xls"
xlPath = "C:\Documents and Settings\mconea\My Documents\Base de données\Exemples\Calendar_
jvf_final\
NewTemplat
e.xls"
'---------------
Dim retval
Dim x As Integer
Dim MyFontColor As Long
Dim MyWeekCount
Dim LastUsedRow As Long
Dim CurrentRow As Long
Dim MyOffset As Integer
Dim rVal$
Dim MyWeek As Integer
Dim MyDay$
Dim msg
Dim MyDate$
Dim frm
'-----------variables for the different calendars
'StartDay
Dim MyStartDay$
'vb Day of week constant
Dim vbDay As Integer
'gathering names of days of week from weeks tables
Dim sql_Week$
'sql string for each event day
Dim sql_Calendar$
'field name for statements
Dim MyStatementName$
'comparison value for adding the dates to the event day headers
'value is MyCal+1
Dim EventStart As Integer
'we set up the individual calendar parameters
Select Case MyCal
Case Is = 36
MyStartDay$ = "Sunday"
'vb Day of week constant
vbDay = 1
'get the day names header
sql_Week = "Select sun,mon,tues,wed,thurs,fri
,sat FROM tblweeks"
'comparison value for adding the dates to the event day headers
'it is MyCal+1
EventStart = 37
Case Is = 45
MyStartDay$ = "Sunday"
'vb Day of week constant
vbDay = 1
'get the day names header
sql_Week = "Select sun,mon,tues,wed,thurs,fri
,sat FROM tblweeks"
'comparison value for adding the dates to the event day headers
'value is MyCal+1
EventStart = 46
Case Is = 55
MyStartDay$ = "Monday"
'vb Day of week constant
vbDay = 2
'get the day names header
sql_Week = "Select mon,tues,wed,thurs,fri,sat
,sun FROM tblweeks"
'comparison value for adding the dates to the event day headers
'value is MyCal+1
EventStart = 56
Case Else
'just in case we don't get 36 or 45 or 55
MsgBox "don't recognize calander " & MyCal: Exit Sub
End Select
'user must supply a valid start date for the calendar
msg = "Please supply a " & MyStartDay & " start date"
MyDate = InputBox(msg)
'cancelled for no input
If MyDate = "" Then Exit Sub
'check for a date
If Not IsDate(MyDate) Then MsgBox "Must supply a valid date": Exit Sub
'make sure it startson the right day
If DatePart("w", MyDate) <> vbDay Then MsgBox MyDate & " is not a " & MyStartDay: Exit Sub
'weeks table name ends with the calendar type so
'we add it to the sql string to complete the table name
'then filter by a specific week
sql_Week = sql_Week & MyCal & " where week="
'eventday field names also end with calendar type so
'complete the desired eventday name here
sql_Calendar = "Select * from tblCalendar WHERE EventDay" & MyCal & "= "
'complete the field name for statements--it ends with E or F
MyStatementName = "Calendar_" & MyLang
'fill the months array
'it contains the names of the month in English or French as needed
'we use this to format the displayed date for certain eventdays
'use a function so we will wait until the array is filled
retval = FillMonths(MyLang)
'OK, we're ready
Set Db = CurrentDb
Set appexcel = CreateObject("Excel.Applic
ation")
'turn off this option or we have an annoying error triangle
'in the upper left corner of the Event days after we
'transfer the numbers over
'appexcel.ErrorCheckingOpt
ions.Numbe
rAsText = False
'add a workbook
'appexcel.workbooks.Add
appexcel.workbooks.Open (xlPath)
'open a Popup form so the user can see some action
'while the spreadsheet is being filled
frm = "StatusForm"
DoCmd.OpenForm frm
Set frm = Forms(frm)
'find out how many weeks are in the weeks table
a$ = "Select* FROM tblWeeks" & MyCal
Set rs_weeks = Db.OpenRecordset(a$)
rs_weeks.MoveLast
'get the week count. records are numbered starting with 0
'so subtract 1
MyWeekCount = rs_weeks.RecordCount - 1
'put in the day header-it is always week 0
a$ = sql_Week & 0
Set rs_weeks = Db.OpenRecordset(a$)
'day header goes in row 3
appexcel.ActiveSheet.Range
("A3").Cop
yFromRecor
dset rs_weeks
'when in the loop we add a row to the last row so set up the
'last row number here. first week of event days starts in row 6
'and we increment right away so set up row 5 as last row
LastUsedRow = 5
'set up main loop and loop through all the weeks.
'week 1 starts the event day list.
For MyWeek = 1 To MyWeekCount
a$ = sql_Week & MyWeek
Set rs_weeks = Db.OpenRecordset(a$)
'increment row loop counter
LastUsedRow = LastUsedRow + 1
'concatenate the range address
a$ = "A" & LastUsedRow & ":" & "G" & LastUsedRow
'format the color and font
appexcel.Range(a$).Interio
r.ColorInd
ex = 15
appexcel.Range(a$).Select
With appexcel.Selection.Font
.Name = "Arial"
.Size = 10
.Bold = True
End With
'we'll use range reference instead of cell reference
rVal = "A" & LastUsedRow
'transfer the event days
appexcel.ActiveSheet.Range
(rVal).Cop
yFromRecor
dset rs_weeks
'make a new event day recordset for the current week getting all fields
'since fields are numbered starting at 0, the inclustion of the
'week number field (field 0) in the sql statement makes the day fields
'number from 1 to 7
'this conventiently corresponds to spreadsheet
'column numbers which start at 1 so columns A-G =1 thru 7 represent one week
'we use the field number to help place the data in the proper column
'field #1 of the table must start with the start day of the calendar
'some start on Sunday, others start on Monday
a$ = "Select* FROM tblWeeks" & MyCal & " Where Week=" & MyWeek
Set rs_weeks = Db.OpenRecordset(a$)
rs_weeks.MoveFirst
'now loop through the days of the week looking for statements
'in tblCalendar for the current event day
For x = 1 To 7
'some weeks don't use all the days and data is text
'so we need to concatenate a beginning space
'or get null errors
MyDay = "" & rs_weeks.Fields(x).Value
'MsgBox Myday
'check for an entry because some weeks don't use all the days
If IsNumeric(Val(MyDay)) Then
'change the Popup forms caption here
With frm
.Caption = "Filling Event Day " & MyDay
'.Refresh
End With
'event days between MyCal and -26 have a date attached
'so append the date to the header
'have to check for nulls because an empty string
'"" and a null from above (no event day on one of the weekdays)
'will be evaluated as 0
'and dates of day 0 will populate where there are
'no "real" days
If Not IsNull(rs_weeks.Fields(x).
Value) Then
'format here
'we send the calendar type (36,45,55) to use in the
'function's formula
'MyDate is the supplied starting date
'MyDay is the eventday number
If (MyDay > -27 And MyDay < EventStart) Then appexcel.Cells(LastUsedRow
, x) = MyDateFormat(MyCal, MyDate, MyDay)
'make day 0 a different color
If Trim(MyDay) = "0" Then appexcel.Cells(LastUsedRow
, x).Interior.ColorIndex = 6
End If
'if we're here MyDay contains a numbered event day so look for statements
a$ = sql_Calendar & QQQ(MyDay)
'recordset of statements for the day
Set rs_statements = Db.OpenRecordset(a$)
'check for records
If rs_statements.RecordCount <> 0 Then
'have records so put them on spreadsheet and format
'since excel column corresponds to field number we check the last filled row
'to see if we're in the right place
If Val(appexcel.Cells(LastUse
dRow, x).Value) <> Val(MyDay) Then
MsgBox "Expected Event day " & MyDay & " at " & appexcel.Cells(LastUsedRow
, x)
Exit Sub
End If
rs_statements.MoveFirst
'we fill underneath the event day using offests so set the offset counter
MyOffset = 0
Do Until rs_statements.EOF
MyOffset = MyOffset + 1
'MsgBox "last row= " & LastUsedRow
'MsgBox "row to fill is " & MyRange.Row
'Cells(lastUsedRow,x) contains the event day so
'we offset downwards from LastUsedRow and stay in the same column (x)
'use Range object for clarity so get the address of the desired fill cell
rVal = appexcel.Cells(LastUsedRow
, x).Offset(MyOffset, 0).Address
'appexcel.Range(rVal) = rs_statements![Calendar_E]
appexcel.Range(rVal) = rs_statements.Fields(MySta
tementName
)
'Format cell
Select Case rs_statements![Directorate
ID]
Case "OPS"
MyFontColor = vbGreen
Case "COMM"
MyFontColor = vbBlue
Case "FINANCE"
MyFontColor = &H4080&
Case "DCEO"
MyFontColor = &HFFFF00
Case "IT"
MyFontColor = &HFF80FF
Case "PFACS"
MyFontColor = &H4080&
End Select
With appexcel.Range(rVal).Font
.Color = MyFontColor
.Size = 7
End With
rs_statements.MoveNext
Loop
End If
End If
Next x
'done looking for statements if we have any, the last used row will not be
'equal to the current header row. If there are no statements we add a blank row
CurrentRow = LastCell(appexcel.ActiveSh
eet).Row
'MsgBox "current row is " & CurrentRow & vbNewLine & "lastusedrow is " & LastUsedRow
'If last=current then add a row
If CurrentRow = LastUsedRow Then
LastUsedRow = LastUsedRow + 1
Else
LastUsedRow = LastCell(appexcel.ActiveSh
eet).Row
End If
Next MyWeek
DoCmd.Close acForm, "StatusForm"
With appexcel
'get back to the top of the sheet
.Range("A1").Select
'set to page break view and shrink it some
.ActiveWindow.View = xlPageBreakPreview
'percent expressed as whole number-change it if neccessary
.ActiveWindow.Zoom = 35
.Visible = True
End With
'clean up to release memory
Set appexcel = Nothing
rs_weeks.Close
rs_statements.Close
Set Db = Nothing
Set frm = Nothing
End Sub
Hope someone has an idea.
thanks
stronghold888
