' Per_0 = DLookup("Запись", "Системная", "Код = 10")
Per_0 = "01/01/2002"
DoCmd.SetWarnings True
DoCmd.RunSQL "DELETE DISTINCTROW Nachisl.*, Nachisl.Data_nach FROM Nachisl WHERE (((Nachisl.Data_nach) < #" & Per_0 & "#));"
DoCmd.RunSQL "DELETE DISTINCTROW Oplata.*, Oplata.Data_oplat FROM Oplata WHERE (((Oplata.Data_oplat) < #" & Per_0 & "#));"
DoCmd.RunSQL "DELETE DISTINCTROW Saldo.*, Saldo.Mes FROM Saldo WHERE (((Saldo.Mes) < #" & Per_0 & "#));"
DoCmd.RunSQL "DELETE DISTINCTROW Treb.*, Treb.Data_nach FROM Treb WHERE (((Treb.Data_nach) < #" & Per_0 & "#));"
End Function
Public Function treb_begin()
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE DISTINCTROW Plat_tr.* FROM Plat_tr;"
DoCmd.RunSQL "INSERT INTO PLAT_TR ( CODE_TR, SUM_NACH, NDS_NACH, SUM_VSEGO ) SELECT DISTINCTROW Partner.CODE, Sum(Сумма_начислений.Sum_Sum_nach) AS Sum_Sum_Sum_nach, Sum(Сумма_начислений.Sum_NDS_nach) AS Sum_Sum_NDS_nach, Sum([Sum_Sum_nach]+[Sum_NDS_nach]) AS SUM_VSEGO FROM Partner INNER JOIN [Сумма_начислений] ON Partner.CODE = Сумма_начислений.Abon_nach GROUP BY Partner.CODE;"
DoCmd.OpenQuery "Обновл_Требован"
End Function
- Модуль для перевода чисел в текст прописью:
' определение внешней функции NumberToText
Private Declare Function NumberToText Lib "DIG2TEXT" (ByVal Num As Double, ByVal ObjID$, ByVal flags As Long, ByVal ResultVal$) As Long
Function CapitalizeFirst(Str)
' Переводит первую букву в поле на верхний регистр;
' оставляет остальные символы не измененными.
Dim strTemp As String
strTemp = Trim(Str)
CapitalizeFirst = UCase(Left(strTemp, 1)) & Mid(strTemp, 2)
End Function
Function Okruglen(Num As Currency)
Okruglen = Format(Num, "#0.00")
End Function
' Spaces256$ создает пустую строку длиной 256 символов
Function Spaces256$()
Temp$ = "0123456789abcdef"
Temp$ = Temp$ & Temp$ & Temp$ & Temp$
Temp$ = Temp$ & Temp$ & Temp$ & Temp$
Spaces256$ = Temp$
End Function
' NumberToRussianText$ преобразует число Number в строку, в которой это число записано прописью
' на русском языке в соответствии с объектом ObjectID$. Если Flags = 256, то первый символ строки
' делается заглавным.
Function NumberToRussianText$(Number As Double, ObjectID$, flags As Long)
Dim ResultVal$, ResultLength As Long
ResultVal$ = Spaces256$()
ResultLength = NumberToText(Number, ObjectID$, flags, ResultVal$)
NumberToRussianText$ = Left$(ResultVal$, ResultLength)
End Function
' Пример использования функции NumberToRussianText$
'Sub ConvertToRusTextExample()
' ResultVal$ = NumberToRussianText$(123.5, "USD", 256)
' Debug.Print ResultVal$
'End Sub
- Модуль для служебных функций
Option Compare Database
Option Explicit
Public Kod_typ_dv As Integer
Public Archif As Boolean
Public Board As Integer
Public Obn As Boolean
'------------------------------------------------------------
' Restore_Form
'
'------------------------------------------------------------
Function Restore_Form(Name_form As Form)
On Error GoTo Restore_Form_Err
Dim frm As Form
Set frm = Name_form
frm.SetFocus
DoCmd.Restore
Restore_Form_Exit:
Exit Function
Restore_Form_Err:
MsgBox Error$
Resume Restore_Form_Exit
End Function
Sub Set_Controls(Dostup As Integer)
'1- Запретить изменения, 2- разрешить
On Error GoTo Set_Controls_Err
Dim frm As Form, ctl As Control, D As Integer
Set frm = Screen.ActiveForm
' Перебирает все компоненты семейства Controls.
For Each ctl In frm.Controls
' Проверяет, является ли элемент управления списком или текстовым блоком
If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then
If Dostup = 1 Then
If ctl.Name = "ПолеПоиска" Then
Else
With ctl
.Enabled = False
.Locked = True
' .SetFocus
' .OnEnter = "=Вход_ПолеСоСписком()"
' .OnExit = "=Выход_ПолеСоСписком()"
End With
End If
ElseIf Dostup = 2 Then
With ctl
' .SetFocus
.Enabled = True
.Locked = False
End With
End If
End If
Next ctl
Set_Controls_Exit:
Exit Sub
Set_Controls_Err:
MsgBox Error$
Resume Set_Controls_Exit
End Sub
'------------------------------------------------------------
' Close_Form
'
'------------------------------------------------------------
Function Close_Form()
On Error GoTo Close_Form_Err
Dim strFormName As String
' strFormName = Screen.ActiveDatasheet.Name
strFormName = Screen.ActiveForm.FormName
' DoCmd.Close acQuery, strFormName, acSaveYes
If strFormName = "Кнопочная форма" Then
SendKeys "{ESC}", False
Else
DoCmd.Close acForm, strFormName, acSaveYes
End If
Close_Form_Exit:
Exit Function
Close_Form_Err:
If Err.Number = 2475 Then
strFormName = Screen.ActiveDatasheet.Name
DoCmd.Close acQuery, strFormName, acSaveYes
'frm.SetFocus
DoCmd.Restore
'Restore_Form ("Forms![Кнопочная форма]")
Else
' MsgBox Error$
Resume Close_Form_Exit
End If
End Function
Function Exit_Main()
DoCmd.Quit acSave
End Function
Function IsForm(NameForm As String) As Integer
' Возвращает True, если актиным окном является форма.
Dim strFormName As String
On Error Resume Next
strFormName = Screen.ActiveForm.FormName
If Err Then
IsForm = False
Else
If strFormName = NameForm Then
IsForm = True
Else
IsForm = False
End If
End If
On Error GoTo 0
End Function
Function EditN() As Integer
On Error GoTo EditN_Err
Dim frm As Form
Dim varTmp As Variant
Set frm = Screen.ActiveForm
' Включает ввод записей с помощью свойства
' "Разрешить изменение" (AllowEdits). Задает для свойства
' "Работа с записями" (DefaultEditing) значение 1 (Ввод данных).
' frm.AllowEdits = False
'frm.DefaultEditing = 1
' Включает элементы в области данных
varTmp = EnableControls("Detail", False, True)
Exit Function
EditN_Err:
MsgBox Err.Description
Exit Function
End Function
Function EditD() As Integer
On Error GoTo EditD_Err
Dim frm As Form
Dim varTmp As Variant
Set frm = Screen.ActiveForm
' Включает ввод записей с помощью свойства
' "Разрешить изменение" (AllowEdits). Задает для свойства
' "Работа с записями" (DefaultEditing) значение 1 (Ввод данных).
' frm.AllowEdits = True
'frm.DefaultEditing = 1
' Включает элементы в области данных
varTmp = EnableControls("Detail", True, False)
Exit Function
EditD_Err:
MsgBox Err.Description
Exit Function
End Function
Function EnableControls(strWhichSection As String, intState As Integer, intLocked As Integer) As Integer
' Включает и отключает элементы управления в указанных разделах формы.
Dim frm As Form
Dim ctl As Control
Dim intX As Integer, intSelectedSection As Integer
' Использует активную форму. Если активной формы нет,
' осуществляет выход из формы без вывода сообщения об ошибке.
On Error Resume Next
Set frm = Screen.ActiveForm
If Err Then
EnableControls = False
On Error GoTo 0
Exit Function
End If
' Определяет допустимые значения аргумента strWhichSection.
Select Case UCase$(strWhichSection)
Case "FORM HEADER"
intSelectedSection = 1
Case "PAGE HEADER"
intSelectedSection = 3
Case "DETAIL"
intSelectedSection = 0
Case "PAGE FOOTER"
intSelectedSection = 4
Case "FORM FOOTER"
intSelectedSection = 2
Case Else
MsgBox "Недопустимый аргумент", , "EnableControls"
EnableControls = False
Exit Function
End Select
' Присваивает значение аргумента intState, intLocked всем
' элементам управления в указанном разделе.
For intX = 0 To frm.Count - 1
Set ctl = frm(intX)
If ctl.Section = intSelectedSection Then
On Error Resume Next
ctl.Enabled = intState
ctl.Locked = intLocked
On Error GoTo 0
End If
Next intX
EnableControls = True
End Function
'------------------------------------------------------------
' К_полю_поиска
'
'------------------------------------------------------------
Function К_полю_поиска()
On Error GoTo К_полю_поиска_Err
Dim Fr As Form
Set Fr = Screen.ActiveForm
Fr![ПолеПоиска].SetFocus
SendKeys "{F4}", False
К_полю_поиска_Exit:
Exit Function
К_полю_поиска_Err:
MsgBox Error$
Resume К_полю_поиска_Exit
End Function
Function Перед_обновлением()
Dim strMsg As String, strCRLF As String
strCRLF = Chr(13) & Chr(10)
strMsg = "Произведено изменение." & strCRLF & _
"Если все правильно, нажмите Да. Произойдет запись." & strCRLF & _
"При нажатии Нет запись не произойдет," & strCRLF & _
"а при последующем нажатии клавиши Esc отмените изменения."
If MsgBox(strMsg, vbYesNo + vbQuestion + vbDefaultButton2) = vbNo Then
Перед_обновлением = -1
End If
End Function
Function Печать_отчета(stDocName As String)
On Error GoTo Err_Печать_отчета
Dim stDocName1 As String
'stDocName = "Z_Abon_КолПоУлицам"
stDocName1 = stDocName
DoCmd.OpenReport stDocName1, acNormal
Exit_Печать_отчета:
Exit Function
Err_Печать_отчета:
MsgBox Err.Description
Resume Exit_Печать_отчета
End Function
'В данном примере функция IsNull проверяет, имеет ли элемент
'управления пустое (Null) значение.
'Если да, выводится приглашение ввести данные.
'Если элемент управления имеет присвоенное значение,
'выводится сообщение с этим значением.
Sub ControlValue(ctlText As Control)
Dim strMsg As String, strCRLF As String
strCRLF = Chr(13) & Chr(10)
' Проверяет, что элемент управления является полем.
If ctlText.ControlType = acTextBox Then
' При значении Null выводит приглашение ввести данные.
If IsNull(ctlText.Value) Then
strMsg = "Пустое поле '" & _
ctlText.Name & "'." & strCRLF & _
"Введите значение данного поля."
If MsgBox(strMsg, vbQuestion) = vbOK Then
Exit Sub
End If
' Если поле имеет непустое значение, выводит это значение.
Else
MsgBox (ctlText.Value)
End If
End If
End Sub
Function IsLoaded1(ByVal strFormName As String) As Integer
' Возвращает значения True, если форма открыта в режиме формы или таблицы.
Const conObjStateClosed = 0
Const conDesignView = 0
If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
If Forms(strFormName).CurrentView <> conDesignView Then
IsLoaded1 = True
End If
End If
End Function
Function IsLoaded(frmName)
' Проверяет, загружена ли форма.
Const conFormDesign = 0
Dim intX As Integer
IsLoaded = False
For intX = 0 To Forms.Count - 1
If Forms(intX).FormName = frmName Then
If Forms(intX).CurrentView <> conFormDesign Then
IsLoaded = True
Exit Function ' Выход из функции при обнаружении формы.
End If
End If
Next
End Function
'------------------------------------------------------------
' Команды_УдЗап
'
'------------------------------------------------------------
Function Команды_УдЗап()
On Error GoTo Команды_УдЗап_Err
DoCmd.DoMenuItem 0, 1, 7, 0, acMenuVer70 ' Форма, Правка, Удалить запись
Команды_УдЗап_Exit:
Exit Function
Команды_УдЗап_Err:
MsgBox Error$
Resume Команды_УдЗап_Exit
End Function
'------------------------------------------------------------
' Команды_Обновить
'
'------------------------------------------------------------
Function Команды_Обновить()
On Error GoTo Команды_Обновить_Err
DoCmd.Requery ""
Команды_Обновить_Exit:
Exit Function
Команды_Обновить_Err:
MsgBox Error$
Resume Команды_Обновить_Exit
End Function
'------------------------------------------------------------
' Команды_ДобавитьЗап
'
'------------------------------------------------------------
Function Команды_ДобавитьЗап()
On Error GoTo Команды_ДобавитьЗап_Err
DoCmd.DoMenuItem 0, 3, 0, 0, acMenuVer70 ' Форма, Вставка, Запись
Команды_ДобавитьЗап_Exit:
Exit Function
Команды_ДобавитьЗап_Err:
MsgBox Error$
Resume Команды_ДобавитьЗап_Exit
End Function