Диплом - Разработка математической модели и программного обеспечения для задач составления расписания занятий
Подождите немного. Документ загружается.
61
' Расстановка взводов
For i = 1 To 3 'Роты
MakeFrameBorder MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + 2, iCurCol +
1).Address, MyWindow.ActiveSheet.Cells(iCurRow + i * 5 + 1, iCurCol + iHours).Address
With MyWindow.ActiveSheet.Range(MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) *
5 + 2, iCurCol + 1).Address & ":" & MyWindow.ActiveSheet.Cells(iCurRow + i * 5 + 1,
iCurCol + iHours).Address)
.Font.Name = "MS Serif"
.Font.Size = 6
End With
For j = 1 To 5 'Взвода
iPlatoon = 200 + 10 * i + j
If dDay = 1 Or dDay = 4 Then
MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j + 1, iCurCol).Value =
iPlatoon
End If
If dDay = 3 Or dDay = 7 Then
MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j + 1, iCurCol + iHours +
1).Value = iPlatoon
End If
' Rem Поиск занятия в расписании
sqlQuery = "SELECT Предметы.Цвет, Предметы.Кратк_название & ' ' &
План.Тема & '/' & IIF(АвтовставкаТем.Тема is not
null,АвтовставкаТем.Тема,План.Занятие)& ' ' & План.Место_проведения AS Имя,
План.Длина, Расписание.Время "
sqlQuery = sqlQuery & "FROM (((Расписание INNER JOIN План ON
Расписание.Код_занятия=План.Код_занятия)"
sqlQuery = sqlQuery & "INNER JOIN Предметы ON
План.Код_предмета=Предметы.Код_предмета)"
sqlQuery = sqlQuery & "LEFT JOIN [АвтовставкаТем] ON
(Расписание.Дата=АвтовставкаТем.Дата AND
Расписание.Код_занятия=АвтовставкаТем.Код_занятия))"
sqlQuery = sqlQuery & "WHERE Расписание.Дата=CDate('" &
FormatDateTime(dStartWeekDay + dDay - 1, vbShortDate) & "') "
sqlQuery = sqlQuery & "AND Расписание.Взвод=" & Str(iPlatoon)
Set rstLessons = dbsDatabase.OpenRecordset(sqlQuery)
Do Until rstLessons.EOF
Rem занятие найдено, устанавливаем длину и название ячейки
Set fldName = rstLessons.Fields("Имя")
Set fldLong = rstLessons.Fields("Длина")
Set fldTime = rstLessons.Fields("Время")
Set fldColor = rstLessons.Fields("Цвет")
With MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j + 1, iCurCol +
fldTime.Value)
MergeCellsText .Address, .Offset(0, fldLong.Value - 1).Address, fldName.Value
If Not IsNull(fldColor) Then
If fldColor.Value > 0 Then MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) *
5 + j + 1, iCurCol + fldTime.Value).Interior.Color = fldColor.Value
End If
MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j + 1, iCurCol +
fldTime.Value).WrapText = True
End With
rstLessons.MoveNext
Loop
rstLessons.Close
Next j
Next i
iCurCol = iCurCol + iHours
Next dDay
' вторая часть расписания на 4-6 роты
' Заголовок расписания
MyWindow.ActiveSheet.Range("A55:AD55").ColumnWidth = 4.2
MyWindow.ActiveSheet.Range("A55:A116").RowHeight = 20
MergeCellsText "A56", "U56", "РАСПИСАНИЕ"
dStartWeekDay = dSelectedDay - Weekday(dSelectedDay, vbUseSystemDayOfWeek) + 1
MergeCellsText "A57", "U57", "занятий с " & FormatDateTime(dStartWeekDay,
vbLongDate) & " по " & FormatDateTime(dStartWeekDay + 6, vbLongDate)
MergeCellsText "V55", "AB55", "УТВЕРЖДАЮ"
MergeCellsText "V56", "AB56", "начальник учебного отдела"
MyWindow.ActiveSheet.Range("W57").Formula = "подполковник"
MyWindow.ActiveSheet.Range("AA57").Formula = "В.Харичкин"
MyWindow.ActiveSheet.Range("Q104").Formula = "Старший ПНУО п/п-к"
MyWindow.ActiveSheet.Range("X104").Formula = "В.Гусельников"
iCurRow = 59
iCurCol = 1
For dDay = 1 To 7 'цикл по дням недели
If dDay = 4 Then
iCurRow = 83
iCurCol = 1
End If
' Запрос часов по дням
Set rstWeekday = dbsDatabase.OpenRecordset("SELECT * FROM Дни_недели WHERE
день='" & WeekdayName(dDay) & "'")
Set fldHours = rstWeekday.Fields("Кол-во_часов")
iHours = fldHours.Value
rstWeekday.Close
'Заголовок для взводов
If dDay = 1 Or dDay = 4 Then
MyWindow.ActiveSheet.Cells(iCurRow, iCurCol).Value = "№"
With MyWindow.ActiveSheet.Cells(iCurRow + 1, iCurCol)
.Value = "взвод"
.Font.Name = "MS Serif"
.Font.Size = 8
End With
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol).Value = "№"
With MyWindow.ActiveSheet.Cells(iCurRow + 17, iCurCol)
.Value = "взвод"
.Font.Name = "MS Serif"
.Font.Size = 8
End With
62
63
MakeFrameBorder MyWindow.ActiveSheet.Cells(iCurRow, iCurCol).Address,
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + 1).Address
End If
If dDay = 3 Or dDay = 7 Then
MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + iHours + 1).Value = "№"
With MyWindow.ActiveSheet.Cells(iCurRow + 1, iCurCol + iHours + 1)
.Value = "взвод"
.Font.Name = "MS Serif"
.Font.Size = 8
End With
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + iHours + 1).Value = "№"
With MyWindow.ActiveSheet.Cells(iCurRow + 17, iCurCol + iHours + 1)
.Value = "взвод"
.Font.Name = "MS Serif"
.Font.Size = 8
End With
MakeFrameBorder MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + iHours).Address,
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + iHours + 1).Address
End If
' Расстановка часов по дням
MakeFrameBorder MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + 1).Address,
MyWindow.ActiveSheet.Cells(iCurRow + 1, iCurCol + iHours).Address
MakeFrameBorder MyWindow.ActiveSheet.Cells(iCurRow + 17, iCurCol + 1).Address,
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + iHours).Address
For iHourCounter = 1 To iHours 'цикл по часам в дне dDay
MyWindow.ActiveSheet.Cells(iCurRow + 1, iCurCol + iHourCounter).Value =
iHourCounter
MyWindow.ActiveSheet.Cells(iCurRow + 17, iCurCol + iHourCounter).Value =
iHourCounter
Next
If dDay < 7 Then
MergeCellsText MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + 1).Address,
MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + iHours).Address, WeekdayName(dDay) & "
- " & FormatDateTime(dStartWeekDay + dDay - 1, vbLongDate)
MergeCellsText MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + 1).Address,
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + iHours).Address,
WeekdayName(dDay) & " - " & FormatDateTime(dStartWeekDay + dDay - 1, vbLongDate)
Else
MergeCellsText MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + 1).Address,
MyWindow.ActiveSheet.Cells(iCurRow, iCurCol + iHours).Address, WeekdayName(dDay)
MergeCellsText MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + 1).Address,
MyWindow.ActiveSheet.Cells(iCurRow + 18, iCurCol + iHours).Address,
WeekdayName(dDay)
End If
' Расстановка взводов
For i = 4 To 6 'Роты
MakeFrameBorder MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 - 13, iCurCol +
1).Address, MyWindow.ActiveSheet.Cells(iCurRow + i * 5 - 14, iCurCol + iHours).Address
With MyWindow.ActiveSheet.Range(MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) *
5 - 13, iCurCol + 1).Address & ":" & MyWindow.ActiveSheet.Cells(iCurRow + i * 5 - 14,
iCurCol + iHours).Address)
.Font.Name = "MS Serif"
.Font.Size = 6
End With
For j = 1 To 5 'Взвода
iPlatoon = 200 + 10 * i + j
If dDay = 1 Or dDay = 4 Then
MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j - 14, iCurCol).Value =
iPlatoon
End If
If dDay = 3 Or dDay = 7 Then
MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j - 14, iCurCol + iHours +
1).Value = iPlatoon
End If
' Rem Поиск занятия в расписании
sqlQuery = "SELECT Предметы.Цвет, Предметы.Кратк_название & ' ' &
План.Тема & '/' & IIF(АвтовставкаТем.Тема is not
null,АвтовставкаТем.Тема,План.Занятие)& ' ' & План.Место_проведения AS Имя,
План.Длина, Расписание.Время "
sqlQuery = sqlQuery & "FROM (((Расписание INNER JOIN План ON
Расписание.Код_занятия=План.Код_занятия)"
sqlQuery = sqlQuery & "INNER JOIN Предметы ON
План.Код_предмета=Предметы.Код_предмета)"
sqlQuery = sqlQuery & "LEFT JOIN [АвтовставкаТем] ON
(Расписание.Дата=АвтовставкаТем.Дата AND
Расписание.Код_занятия=АвтовставкаТем.Код_занятия))"
sqlQuery = sqlQuery & "WHERE Расписание.Дата=CDate('" &
FormatDateTime(dStartWeekDay + dDay - 1, vbShortDate) & "') "
sqlQuery = sqlQuery & "AND Расписание.Взвод=" & Str(iPlatoon)
Set rstLessons = dbsDatabase.OpenRecordset(sqlQuery)
Do Until rstLessons.EOF
Rem занятие найдено, устанавливаем длину и название ячейки
Set fldName = rstLessons.Fields("Имя")
Set fldLong = rstLessons.Fields("Длина")
Set fldTime = rstLessons.Fields("Время")
Set fldColor = rstLessons.Fields("Цвет")
With MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j - 14, iCurCol +
fldTime.Value)
MergeCellsText .Address, .Offset(0, fldLong.Value - 1).Address, fldName.Value
If Not IsNull(fldColor) Then
If fldColor.Value > 0 Then MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) *
5 + j - 14, iCurCol + fldTime.Value).Interior.Color = fldColor.Value
End If
MyWindow.ActiveSheet.Cells(iCurRow + (i - 1) * 5 + j - 14, iCurCol +
fldTime.Value).WrapText = True
End With
rstLessons.MoveNext
Loop
rstLessons.Close
Next j
64
65
Next i
iCurCol = iCurCol + iHours
Next dDay
End Sub
Sub MakeFrameBorder(strStartCell, strEndCell, Optional wInsideVertical = xlThin)
'Изменение рамки вокруг блока (внутри тонкие, снаружи толстые)
Set MyRange = MyWindow.ActiveSheet.Range(strStartCell & ":" & strEndCell)
MyRange.Borders(xlDiagonalDown).LineStyle = xlNone
MyRange.Borders(xlDiagonalUp).LineStyle = xlNone
With MyRange.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With MyRange.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium 'xlThin
.ColorIndex = xlAutomatic
End With
With MyRange.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With MyRange.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With MyRange.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = wInsideVertical
.ColorIndex = xlAutomatic
End With
With MyRange.Borders(xlInsideHorizontal)
' .LineStyle = xlContinuous
.Weight = xlThin
' .ColorIndex = xlAutomatic
End With
End Sub
Sub MergeCellsText(strStartCell, strEndCell, strText)
Rem Объединение ячеек и надпись строки по центру
With MyWindow.ActiveSheet.Range(strStartCell & ":" & strEndCell)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlVAlignTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Formula = strText
End With
End Sub
Sub SetPageProperties(Optional Orient = xlLandscape)
'
' Настройки параметров страницы
'
With MyWindow.ActiveSheet.PageSetup
' .PrintTitleRows = ""
' .PrintTitleColumns = ""
' .PrintArea = ""
.Orientation = Orient
.LeftMargin = Application.InchesToPoints(0.4)
.RightMargin = Application.InchesToPoints(0.4)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.4)
' .HeaderMargin = Application.InchesToPoints(0.5)
' .FooterMargin = Application.InchesToPoints(0.5)
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
' .Draft = False
.PaperSize = xlPaperA4
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = 100
' .PrintErrors = xlPrintErrorsDisplayed
End With
End Sub
Sub SetPageProperties1(Optional Orient = xlLandscape)
'
' Настройки параметров страницы
'
With MyWindow.ActiveSheet.PageSetup
' .PrintTitleRows = ""
' .PrintTitleColumns = ""
' .PrintArea = ""
.Orientation = Orient
.LeftMargin = Application.InchesToPoints(0.4)
.RightMargin = Application.InchesToPoints(0.4)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.4)
' .HeaderMargin = Application.InchesToPoints(0.5)
' .FooterMargin = Application.InchesToPoints(0.5)
66
67
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
' .Draft = False
.PaperSize = xlPaperA4
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = 100
' .PrintErrors = xlPrintErrorsDisplayed
End With
End Sub
Sub SetPageProperties2(Optional Orient = xlLandscape)
'
' Настройки параметров страницы
'
With MyWindow.ActiveSheet.PageSetup
' .PrintTitleRows = ""
' .PrintTitleColumns = ""
' .PrintArea = ""
.Orientation = Orient
.LeftMargin = Application.InchesToPoints(0.4)
.RightMargin = Application.InchesToPoints(0.4)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.4)
' .HeaderMargin = Application.InchesToPoints(0.5)
' .FooterMargin = Application.InchesToPoints(0.5)
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
' .Draft = False
.PaperSize = xlPaperA4
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
.Zoom = 80
' .PrintErrors = xlPrintErrorsDisplayed
End With
End Sub