Разработка АРМ сотрудника НОЧУ ДПО ЦПК Учебный центр ИнфоТеКС (1089310), страница 14
Текст из файла (страница 14)
Dim ФлагЗанятий As Boolean
If IsNull(Me!ГруппаСуб.Form!ДатаНачала) Then
MsgBox "Не введена дата начала занятий", vbInformation
Exit Sub
End If
If IsNull(Me!ГруппаСуб.Form!КолЧас) Then
MsgBox "Не введено количество часов", vbInformation
DoCmd.OpenForm "Специальность"
Exit Sub
End If
ВсегоЧас = Me!ГруппаСуб.Form!КолЧас
ДатаЗанятий = Me!ГруппаСуб.Form!ДатаНачала
ЧасДень = 4
Set rst = CurrentDb.OpenRecordset("График", dbOpenDynaset, dbSeeChanges)
Do While ВсегоЧас > 0
ФлагЗанятий = False
If Weekday(ДатаЗанятий, vbMonday) <= 5 Then ФлагЗанятий = True
'If IsNull(DLookup("ДатаВыходной", "ВыходнойРабочий", "ДатаВыходной=" & Format(ДатаЗанятий, "mm-dd-yyyy"))) Then ФлагЗанятий = True
'If IsNull(DLookup("ДатаРабочий", "РабочийВыходной", "ДатаРабочий=" & Format(ДатаЗанятий, "mm-dd-yyyy"))) Then ФлагЗанятий = False
'If IsNull(DLookup("ДатаПраздник", "Праздник", "ДатаПраздник=" & Format(ДатаЗанятий, "mm-dd-yyyy"))) Then ФлагЗанятий = False
If ФлагЗанятий Then
rst.AddNew
rst![№Группа] = Me!ГруппаСуб.Form![№Группа]
rst!ДатаЗанятий = ДатаЗанятий
rst!КолЧас = ЧасДень
ВсегоЧас = ВсегоЧас - ЧасДень
rst.Update
EndIf
ДатаЗанятий = DateAdd("d", 1, ДатаЗанятий)
Loop
rst.Close
Me!ГруппаСуб.Form!ДатаОкончания = DateAdd("d", -1, ДатаЗанятий)
Me!График.Requery
End Sub
Private Sub Свидетельство_Click()
On Error GoTo Err_Свидетельство_Click
DoCmd.OpenReport "Свидетельство", acViewPreview, , "[№Учащийся]=" & Forms!УчебныйПроцесс!ГруппаУчащийсяСуб.Form!№Учащийся
Exit_Свидетельство_Click:
ExitSub
Err_Свидетельство_Click:
MsgBox Err.Description
Resume Exit_Свидетельство_Click
End Sub
Private Sub СоздЖурнал_Click()
On Error GoTo Err_СоздЖурнал_Click
Dim pathBase As String
Dim pathDot As String
Dim pathDoc As String
Dim WordObj As Word.Application
Dim rst As DAO.Recordset
Dim WordTable As Word.Table
Dim WordRange As Word.Range
Dim WordDoc As Word.Document
Dim str As String
Dim strSQL As String
Dim countRec As Variant
pathBase = CurrentProject.Path
pathDot = pathBase & "\Шаблоны\" & Nz(DLookup("ИмяШаблон", "ШаблоныДок", "КодШаблон=8"), "")
IfDir(pathDot) = "" Then
MsgBox "Шаблон документа не найден"
ExitSub
EndIf
pathDoc = pathBase& "\" &Nz(DLookup("ИмяФайлаДок", "ШаблоныДок", "КодШаблон=8"), "")
If Dir(pathDoc) <> "" Then
Kill pathDoc
End If
FileCopy pathDot, pathDoc
Set WordObj = CreateObject("Word.Application")
WordObj.Visible = True
WordObj.Documents.Open pathDoc
WithWordObj.ActiveDocument.Bookmarks
.Item("НомГрупп").Range.Text = Nz(DLookup("№Группа", "Группа"), " ")
.Item("ДатаНачало").Range.Text = Nz(DLookup("ДатаНачала", "Группа"), " ")
.Item("ДатаКонец").Range.Text = Nz(DLookup("ДатаОкончания", "Группа"), " ")
End With
WordObj.Activate
Set WordObj = Nothing
Exit_СоздЖурнал_Click:
Exit Sub
Err_СоздЖурнал_Click:
MsgBox Err.Description
Resume Exit_СоздЖурнал_Click
End Sub
Private Sub СоздЗаяв_Click()
On Error GoTo Err_СоздЗаяв_Click
Dim pathBase As String
Dim pathDot As String
Dim pathDoc As String
Dim WordObj As Word.Application
Dim rst As DAO.Recordset
Dim str As String
Dim strSQL As String
pathBase = CurrentProject.Path
pathDot = pathBase & "\Заявление\" & Nz(DLookup("ИмяШаблон", "ШаблоныДок", "КодШаблон=10"), "")
IfDir(pathDot) = "" Then
MsgBox "Шаблон документа не найден"
ExitSub
EndIf
pathDoc = pathBase& "\" &Nz(DLookup("ИмяФайлаДок", "ШаблоныДок", "КодШаблон=10"), "")
If Dir(pathDoc) <> "" Then
Kill pathDoc
End If
FileCopy pathDot, pathDoc
Set WordObj = CreateObject("Word.Application")
WordObj.Visible = True
WordObj.Documents.Open pathDoc
Set rst = CurrentDb.OpenRecordset("ЗапросСоздЗаяв")
str = ""
With WordObj.ActiveDocument.Bookmarks
.Item("ОбрУч").Range.Text = Nz(DLookup("Вставка1", "ШаблоныДок", "КодШаблон=10"), " ")
.Item("ФИО_Уч").Range.Text = Nz(DLookup("ФИО", "ЗапросСоздЗаяв", "[№Учащийся]=" & Forms!УчебныйПроцесс!ГруппаУчащийсяСуб.Form!№Учащийся), " ")
.Item("ДатаРожд").Range.Text = Nz(DLookup("ДатаРождения", "ЗапросСоздЗаяв", "[№Учащийся]=" & Forms!УчебныйПроцесс!ГруппаУчащийсяСуб.Form!№Учащийся), " ")
End With
WordObj.Activate
Set WordObj = Nothing
Exit_СоздЗаяв_Click:
Exit Sub
Err_СоздЗаяв_Click:
MsgBox Err.Description
Resume Exit_СоздЗаяв_Click
End Sub
Private Sub СоздСписУд_Click()
On Error GoTo Err_СоздСписУд_Click
Dim pathBase As String
Dim pathDot As String
Dim pathDoc As String
Dim WordObj As Word.Application
Dim WordTable As Word.Table
Dim WordRange As Word.Range
Dim WordDoc As Word.Document
Dim rst As DAO.Recordset
Dim str As String
Dim strSQL As String
Dim countRec As Variant
pathBase = CurrentProject.Path
pathDot = pathBase & "\Списки\" & Nz(DLookup("ИмяШаблон", "ШаблоныДок", "КодШаблон=6"), "")
IfDir(pathDot) = "" Then
MsgBox "Шаблон документа не найден"
ExitSub
EndIf
pathDoc = pathBase& "\" &Nz(DLookup("ИмяФайлаДок", "ШаблоныДок", "КодШаблон=6"), "")
If Dir(pathDoc) <> "" Then
Kill pathDoc
End If
FileCopy pathDot, pathDoc
Set WordObj = CreateObject("Word.Application")
WordObj.Visible = True
WordObj.Documents.Open pathDoc
strSQL = "SELECT СоздСпискаУд.* " & _
"FROMСоздСпискаУд " & _
"WHERE (((СоздСпискаУд.№Группа)='" & ГруппаДляСвязи & "'));"
Set rst = CurrentDb.OpenRecordset(strSQL, , dbReadOnly)
rst.MoveLast
rst.MoveFirst
With WordObj.ActiveDocument.Bookmarks
.Item("НомГруппы").Range.Text = Nz(rst![№Группа], " ")
End With
Set WordDoc = WordObj.ActiveDocument
Set WordTable = WordDoc.Tables(1)
countRec = 0
Do Until rst.EOF
WordTable.Rows.Add
countRec = countRec + 1
WordTable.Cell(countRec + 1, 1).Range.InsertAfter countRec
WordTable.Cell(countRec + 1, 2).Range.InsertAfter Nz(rst![№Учащийся], " ")
WordTable.Cell(countRec + 1, 3).Range.InsertAfter Nz(rst!СвидНомер, " ")
rst.MoveNext
Loop
WordTable.Rows.Add
WordObj.Activate
Set WordObj = Nothing
Exit_СоздСписУд_Click:
Exit Sub
Err_СоздСписУд_Click:
MsgBox Err.Description
Resume Exit_СоздСписУд_Click
EndSub
Листинг А.2 Модуль формы Предварительная запись
Private Sub СогласиеФлаг_AfterUpdate()
DoCmd.Save
End Sub
Private Sub Фильтр_AfterUpdate()
Me.Requery
EndSub
Листинг А.3 Модуль формы Создание группы
Private Sub Form_Open(Cancel As Integer)
Me![№Специальность] = [Forms]![ПредварительнаяЗапись]![Фильтр]
Me.Requery
End Sub
Private Sub №Специальность_AfterUpdate()
Me.Requery
End Sub
Private Sub ПометитьВсе_Click()
Dim strSQL As String
strSQL = "UPDATEПредварительнаяЗаписьSETПредварительнаяЗапись.ВключитьВгруппу = True " & _
"WHERE (((ПредварительнаяЗапись.№Специальность)=" & [Forms]![СозданиеГруппа]![№Специальность] & ") AND ((ПредварительнаяЗапись.Согласие)=true));"
DoCmd.SetWarningsFalse
'DoCmd.OpenQuery "СозданиеГруппаПометить"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Me!ПредварительнаяЗаписьСуб.Requery
End Sub
Private Sub УдалитьОтмеченное_Click()
Dim strSQL As String
strSQL = "UPDATEПредварительнаяЗаписьSETПредварительнаяЗапись.ВключитьВгруппу = false " & _
"WHERE (((ПредварительнаяЗапись.№Специальность)=" & [Forms]![СозданиеГруппа]![№Специальность] & ") AND ((ПредварительнаяЗапись.Согласие)=true));"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Me!ПредварительнаяЗаписьСуб.Requery
End Sub
Private Sub СоздатьГруппу_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "СозданиеГруппаСоздать"
DoCmd.OpenQuery "СозданиеГруппаСоздатьУчащийся"
DoCmd.OpenQuery "СозданиеГруппаОчистить"
DoCmd.SetWarnings True
Me!ПредварительнаяЗаписьСуб.Requery
EndSub
Листинг А.4 Модуль формы Анализ безубыточности
Private Sub ДатаДо_AfterUpdate()
Me!ПостЗатраты.Requery
Me!ПеремЗатраты.Requery
Me!Стоимость1.Requery
End Sub
Private Sub ДатаС_AfterUpdate()
Me!ПостЗатраты.Requery
Me!ПеремЗатраты.Requery
Me!Стоимость1.Requery
End Sub
Private Sub ФильтрСпец_AfterUpdate()
Me!ПостЗатраты.Requery
Me!ПеремЗатраты.Requery
Me!Стоимость1.Requery
EndSub
Листинг А.5 Модуль формы Архив
Private Sub Form_Activate()
Me.Requery
End Sub
Private Sub ДатаДо_AfterUpdate()
Me.Requery
End Sub
Private Sub ДатаС_AfterUpdate()
Me.Requery
End Sub
Private Sub ОткрГруппа_Click()
If IsNull(Me![№Группа]) Then Exit Sub
DoCmd.OpenForm "УчебныйПроцесс", , , , , , Me![№Группа]
End Sub
Private Sub ОтменаФильтра_Click()
On Error GoTo Err_ОтменаФильтра_Click
Me!ФильтрСпец = Null
Me!ДатаС = Null
Me!ДатаДо = Null
Me!ФИО = Null
Me.Requery
Exit_ОтменаФильтра_Click:
Exit Sub
Err_ОтменаФильтра_Click:
MsgBox Err.Description
Resume Exit_ОтменаФильтра_Click
End Sub
Private Sub ФильтрСпец_AfterUpdate()
Me.Requery
End Sub
Private Sub ФИО_AfterUpdate()
Me.Requery
End Sub
ЛистингА.6 МодульформыГруппаСуб
Private Sub Form_Current()
On Error Resume Next
Me.Parent("ГруппаДляСвязи") = Me![№Группа]
DimtmpVarAsVariant
tmpVar = DLookup("Экзамен1", "КоличЭкз", "№Специальность=" &Me!№Специальность)
If Not IsNull(tmpVar) Then
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки1.Visible = True
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки1_Надпись.Caption = tmpVar
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки1_Надпись.Visible = True
Else
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки1.Visible = False
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки1_Надпись.Visible = False
EndIf
tmpVar = DLookup("Экзамен2", "КоличЭкз", "№Специальность=" &Me!№Специальность)
If Not IsNull(tmpVar) Then
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки2.Visible = True
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки2_Надпись.Caption = tmpVar
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки2_Надпись.Visible = True
Else
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки2.Visible = False
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки2_Надпись.Visible = False
EndIf
tmpVar = DLookup("Экзамен3", "КоличЭкз", "№Специальность=" &Me!№Специальность)
If Not IsNull(tmpVar) Then
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки3.Visible = True
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки3_Надпись.Caption = tmpVar
Forms!УчебныйПроцесс!ЭкзаменСуб.Form!№Оценки3_Надпись.Visible = True
Else
![](https://s.studizba.com/z.php?f=/templates/si/i/noavatar.png&w=100&h=100&t=1"){kind=avatar}
