Option Compare Database
Option Explicit
Private Declare Function GetKeyboardLayoutName Lib "user32" _
Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function LoadKeyboardLayout Lib "user32" _
Alias "LoadKeyboardLayoutA" (ByVal HKL As String, _
ByVal flags As Long) As Long
Function KBDToENG()
Call LoadKeyboardLayout("00000409", &H1)
End Function
' Переключение на русскую раскладку
Function KBDToRUS()
Call LoadKeyboardLayout("00000419", &H1)
End Function
Private Sub cmbNewCompany_Click()
DoCmd.OpenTable "Компании"
End Sub
Private Sub cmbNewCompany_LostFocus()
Me.Requery
End Sub
Private Sub cmbNewFilial_Click()
'DoCmd.OpenTable "Филиалы"
Dim rs As DAO.Recordset ' инициируем доступ к БД
Dim НовыйФИЛИАЛ As String
НовыйФИЛИАЛ = InputBox("Наименование филиала:")
If Len(НовыйФИЛИАЛ) > 0 Then
Set rs = CurrentDb.OpenRecordset("Филиалы") ' открываем БД "Филиалы"
rs.AddNew
rs![Филиал] = НовыйФИЛИАЛ
rs.Update
rs.Close
[Form_подчиненная форма Заявки].Form.Refresh
End If
End Sub
Private Sub cmbNewStaffDKR_Click()
Dim rs As DAO.Recordset ' инициируем доступ к БД
Dim Новое_ФИО_сотрудника_ДКР As String
Новое_ФИО_сотрудника_ДКР = InputBox("Фамилия нового сотрудника ДКР")
If Len(Новое_ФИО_сотрудника_ДКР) > 0 Then
Set rs = CurrentDb.OpenRecordset("ФИО сотрудника ДКР") ' открываем БД Новое_ФИО_сотрудника_ДКР
rs.AddNew
rs![ФИО Сотрудника ДКР] = Новое_ФИО_сотрудника_ДКР
rs.Update
rs.Close
[Form_подчиненная форма Заявки].Form.Refresh
End If
End Sub
'Sub ТекущееСоединениеADO()
'Dim cnn As ADODB.Connection
'Set cnn = CurrentProject.Connection
'MsgBox cnn.ConnectionString
'If cnn.State = adStateClosed Then
'MsgBox "Нет подключения"
'Else
'MsgBox "Подключение есть"
'End If
'Set cnn = Nothing
'End Sub
Private Sub Form_Load()
ДатаС.Value = Date - 7
ДатаПо.Value = Date
FilterSubForm
DoCmd.Maximize
СутьВопроса.Enabled = False
KBDToRUS
With [Form_подчиненная форма Заявки].Form.Recordset
If .RecordCount > 0 Then .MoveLast
End With
End Sub
Public Function gflngCompactDatabase( _
CompactingDBPathAndName As String, _
Optional BackupBeforeCompactDB As Boolean = False) As Long
Dim strTempFile As String
On Error GoTo ErrHandler
'Формируем имя для временного ("принимающего") файла'
strTempFile = Left(CompactingDBPathAndName, (Len(CompactingDBPathAndName) - 4)) & _
"_Temp" & Right(CompactingDBPathAndName, 4)
Debug.Print strTempFile & " " & FileLen("Y:\DKR\UKKR\_личные\Антонюк\БД Заявки ДКР\БД Заявки ДКР (v1.2)_be.mdb")
'Создаем (если надо) резервную копию файла БД перед сжатием'
If BackupBeforeCompactDB = True _
Then FileCopy CompactingDBPathAndName, _
Left(CompactingDBPathAndName, (Len(CompactingDBPathAndName) - 4)) & _
"_Backup" & Right(CompactingDBPathAndName, 4)
Debug.Print CompactingDBPathAndName & " " & FileLen("Y:\DKR\UKKR\_личные\Антонюк\БД Заявки ДКР\БД Заявки ДКР (v1.2)_be.mdb")
'Сжимаем файл БД (с перезаписью сжатого файла в новый файл)'
DBEngine.CompactDatabase CompactingDBPathAndName, strTempFile, dbLangCyrillic
Debug.Print CompactingDBPathAndName
'Перезаписываем сжатый (временный файл) на место несжатого (старого файла)'
FileCopy strTempFile, CompactingDBPathAndName
'Удаляем временный файл'
Kill strTempFile
Exit Function
ErrHandler:
'обрабатываем возможные ошибки'
gflngCompactDatabase = Err.Number
Err.Clear: Exit Function
End Function
Private Function ПроверкаДаты(ТекДата As Date) As Boolean
Dim КонецМесяца As Date
КонецМесяца = DateSerial(Year(Date), Month(Date), Day(DaysOfMonth(Date)))
If ТекДата = КонецМесяца Then
ПроверкаДаты = True
Else: ПроверкаДаты = False
End If
End Function
Private Function DaysOfMonth(dDate As Date) As Integer
DaysOfMonth = DateDiff("d", dDate, DateAdd("m", 1, dDate)) + 2
End Function
Private Sub Form_Unload(Cancel As Integer)
Dim FileSizeBefore As Long
FileSizeBefore = Round(FileLen("Y:\DKR\UKKR\_личные\Антонюк\БД Заявки ДКР\БД Заявки ДКР (v1.2)_be.mdb") / 1000000, 2)
If ПроверкаДаты(Date) = True Then
gflngCompactDatabase ("Y:\DKR\UKKR\_личные\Антонюк\БД Заявки ДКР\БД Заявки ДКР (v1.2)_be.mdb")
MsgBox ("База данных сжата с " & FileSizeBefore & "Mb до " _
& Round(FileLen("Y:\DKR\UKKR\_личные\Антонюк\БД Заявки ДКР\БД Заявки ДКР (v1.2)_be.mdb") / 1000000, 2) & "Mb")
End If
'DoCmd.Close
End Sub
Private Sub txLikeFilter_GotFocus()
KBDToRUS
End Sub
Private Sub ДатаПо_Change()
FilterSubForm
End Sub
Private Sub ДатаС_Change()
FilterSubForm
Form_Заявки.ДатаПо.SetFocus
End Sub
Private Sub Кнопка44_Click()
'DoCmd.OpenTable "АндеррайтерИсполнитель", acViewNormal
Dim rs As DAO.Recordset ' инициируем доступ к БД
Dim ФИОКред As String
ФИОКред = InputBox("Новый сотрудник МСБ")
If Len(ФИОКред) > 0 Then
Set rs = CurrentDb.OpenRecordset("АндеррайтерИсполнитель") ' открываем БД Андеррайтер-Исполнитель
rs.AddNew
rs![Андеррайтер-Исполнитель] = ФИОКред
rs.Update
rs.Close
[Form_Заявки Запрос МСБ].Form.Refresh
End If
End Sub
Private Sub Кнопка50_Click()
Dim rs As DAO.Recordset ' инициируем доступ к БД
Dim ФИОКред As String
ФИОКред = InputBox("Новый сотрудник КД")
If Len(ФИОКред) > 0 Then
Set rs = CurrentDb.OpenRecordset("ФИО Кредитчики") ' открываем БД ОТРАСЛИ
rs.AddNew
rs![ФИО Кредитчик] = ФИОКред
rs.Update
rs.Close
[Form_подчиненная форма Заявки].Form.Refresh
End If
End Sub
Private Sub КнопкаЗаявкиНаКК_Click()
DoCmd.OpenReport "ЗаявкиНаКК", acViewPreview
End Sub
Private Sub КнопкаОтрасль_Click()
Dim rs As DAO.Recordset ' инициируем доступ к БД
Dim НоваяОтрасль As String
НоваяОтрасль = InputBox("Новая отрасль")
If Len(НоваяОтрасль) > 0 Then
Set rs = CurrentDb.OpenRecordset("Отрасли") ' открываем БД ОТРАСЛИ
rs.AddNew
rs![Отрасль] = НоваяОтрасль
rs.Update
rs.Close
[Form_подчиненная форма Заявки].Form.Refresh
End If
End Sub
Private Sub кнопкаСбросить_Click()
DoCmd.ShowAllRecords
спФИОСотрудникаДКР = 1
спФилиалы = 1
End Sub
Private Sub Комментарий_AfterUpdate()
Dim КодКорпорат As Integer
If НаборВкладок13.Pages(НаборВкладок13.Value).Name = "Вкладка14" Then
КодКорпорат = [Form_подчиненная форма Заявки].Код
CurrentProject.Connection.Execute "UPDATE Заявки SET [Стал ли заемщик проблемным] = '" & Комментарий & "' WHERE Код = " & КодКорпорат & ""
ElseIf НаборВкладок13.Pages(НаборВкладок13.Value).Name = "Вкладка15" Then
КодКорпорат = [Form_Заявки Запрос МСБ].Код
CurrentProject.Connection.Execute "UPDATE Заявки SET Комментарий = '" & Комментарий & "' WHERE Код = " & КодКорпорат & ""
End If
End Sub
Private Sub НаборВкладок13_Change()
If Me.НаборВкладок13.Value = 0 Then Form_Заявки.спФилиалы.Value = 1
FilterSubForm
If Me.НаборВкладок13.Value = 1 Then Form_Заявки.спФилиалы.Value = 4
FilterSubForm
With Me.НаборВкладок13
With .Pages(.Value).Controls(0).Form.Recordset
If Not .EOF Then .MoveLast
End With
End With
End Sub
Private Sub спФилиалы_Change()
FilterSubForm
End Sub
Private Sub спФИОСотрудникаДКР_Change()
FilterSubForm
End Sub
'==========================================================
' Фильтрация данных в форме. 18/12/2013, Крамаренко К.И.
'==========================================================
Private Sub FilterSubForm()
Dim strFilter As String
Dim dd As Integer
dd = 4
If Form_Заявки.спФИОСотрудникаДКР = 1 And Form_Заявки.спФилиалы = 1 And Me.НаборВкладок13.Value = 0 Then
strFilter = "[Дата поступления заявки в ДКР] Between " & Format$(Me!ДатаС, "\#mm\/dd\/yy\#") & " And " & Format$(Me!ДатаПо, "\#mm\/dd\/yy\#") & " And " & "[Филиал или подразделение] " & dd
ElseIf Form_Заявки.спФИОСотрудникаДКР > 1 And Form_Заявки.спФилиалы = 1 Then
strFilter = "[Дата поступления заявки в ДКР] Between " & Format$(Me!ДатаС, "\#mm\/dd\/yy\#") & " And " & Format$(Me!ДатаПо, "\#mm\/dd\/yy\#") & " And " & "[ФИО Сотрудника ДКР] = " & Me!спФИОСотрудникаДКР
ElseIf Form_Заявки.спФилиалы > 1 And Form_Заявки.спФИОСотрудникаДКР = 1 Then
strFilter = "[Дата поступления заявки в ДКР] Between " & Format$(Me!ДатаС, "\#mm\/dd\/yy\#") & " And " & Format$(Me!ДатаПо, "\#mm\/dd\/yy\#") & " And " & "[Филиал или подразделение] = " & Me!спФилиалы
ElseIf Form_Заявки.спФИОСотрудникаДКР > 1 And Form_Заявки.спФилиалы > 1 Then
strFilter = "[Дата поступления заявки в ДКР] Between " & Format$(Me!ДатаС, "\#mm\/dd\/yy\#") & " And " & Format$(Me!ДатаПо, "\#mm\/dd\/yy\#") & " And " & "[ФИО Сотрудника ДКР] = " & Me!спФИОСотрудникаДКР & " And " & "[Филиал или подразделение] = " & Me!спФилиалы
End If
Me.подчиненная_форма_Заявки.Form.Filter = strFilter
Me.подчиненная_форма_Заявки.Form.FilterOn = True
Me.Заявки_Запрос_МСБ.Form.Filter = strFilter
Me.Заявки_Запрос_МСБ.Form.FilterOn = True
End Sub
'==========================================================
' Фильтр для Тани по Like 29/04/2014, Крамаренко К.И.
'==========================================================
Sub Filterr()
Dim S1 As String
Dim S2 As String
Me.Refresh
S1 = "true"
S2 = "" & Me.txLikeFilter
If Len(S2) > 0 Then
S1 = S1 & " and [Наименование заемщика] In (SELECT [Код] FROM Компании WHERE [Компания] Like '*" & S2 & "*')"
End If
On Error GoTo HandleErr
Me.подчиненная_форма_Заявки.Form.Filter = S1
Me.подчиненная_форма_Заявки.Form.FilterOn = True
Me.Заявки_Запрос_МСБ.Form.Filter = S1
Me.Заявки_Запрос_МСБ.Form.FilterOn = True
ExitHere: Exit Sub
HandleErr: MsgBox ("Ошибка! Ведеите буквы. " + Err.Description)
Resume ExitHere
End Sub
Private Sub txLikeFilter_Change()
Dim S0 As String
S0 = "" & Me.txLikeFilter
Filterr
Me.txLikeFilter.SelStart = Len(S0) + 1
If Nz(Len(Me.txLikeFilter.Value)) = 0 Then
ДатаС = Date - 7
Me.txLikeFilter.SetFocus
FilterSubForm
With [Form_подчиненная форма Заявки].Form.Recordset
If .RecordCount > 0 Then .MoveLast
End With
End If
End Sub
-------------------------------------------
Option Compare Database
Option Explicit
Dim Ключ As Long
'Private Sub Form_Current()
' Ключ1 = Nz(Me.Код, 0)
' Код.ControlSource = Код.ControlSource
'End Sub
Function aaa()
aaa = Ключ
End Function
Private Sub Form_AfterUpdate()
Dim WshNetwork As Object
Dim CpmputerName As String
'Определяем Юзера
Set WshNetwork = CreateObject("WScript.Network")
CpmputerName = WshNetwork.ComputerName
Set WshNetwork = Nothing
CurrentProject.Connection.Execute "UPDATE Заявки SET Юзер = '" & CpmputerName & "', ДатаВнесенияЗаписи = '" & DateValue(Now()) & "' WHERE Код = " & Код & " "
' Эту строку вырезал (добавляла автоматом текущее время): ВремяВнесенияЗаписи = '" & TimeValue(Now()) & "',
End Sub
Private Sub Form_Current()
Dim i As Long
Dim blnIsLocked As Boolean
blnIsLocked = (DateDiff("d", Nz([Form_Заявки Запрос МСБ].Дата_поступления_заявки_в_ДКР, Date), Date) >= 70)
With Me.Section(0).Controls
For i = 0 To Me.Section(0).Controls.Count - 1
With .Item(i)
Select Case .ControlType
Case acTextBox, acComboBox
.Locked = blnIsLocked
Case Else
End Select
End With
Next i
End With
' Отробразить суть вопроса
Form_Заявки.СутьВопроса = Me.Суть_вопроса__выносимого_на_КК_МКК
Form_Заявки.Комментарий = Me.Комментарий
Ключ = Nz(Me.Код, 0)
Код.ControlSource = Код.ControlSource
End Sub
Private Sub АндеррайтерМСБ_AfterUpdate()
Dim ТекСчетчик As Integer
If Not IsNull([Form_Заявки Запрос МСБ].АндеррайтерМСБ) Then
ТекСчетчик = DLookup("Счетчик", "АндеррайтерИсполнитель", "Код = " & [Form_Заявки Запрос МСБ].АндеррайтерМСБ & "")
ТекСчетчик = ТекСчетчик + 1
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE АндеррайтерИсполнитель SET Счетчик = '" & ТекСчетчик & "' WHERE Код = " & [Form_Заявки Запрос МСБ].АндеррайтерМСБ & ""
Me.АндеррайтерМСБ.Requery
End If
End Sub
Private Sub ПолеСоСписком42_AfterUpdate()
Dim ТекСчетчик As Integer
If Not IsNull([Form_Заявки Запрос МСБ].ПолеСоСписком42) Then
ТекСчетчик = DLookup("Счетчик", "Филиалы", "Код = " & [Form_Заявки Запрос МСБ].ПолеСоСписком42 & "")
ТекСчетчик = ТекСчетчик + 1
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE Филиалы SET Счетчик = '" & ТекСчетчик & "' WHERE Код = " & [Form_Заявки Запрос МСБ].ПолеСоСписком42 & ""
Me.ПолеСоСписком42.Requery
End If
End Sub
---------------------------------------------
Option Compare Database
Option Explicit
Dim Ключ As Long
Public ТипЗаключения As Variant
'Private Sub Form_Current()
' Ключ = Nz(Me.Код, 0)
' Код.ControlSource = Код.ControlSource
'End Sub
Function aaa()
aaa = Ключ
End Function
Private Sub Form_AfterUpdate()
Dim WshNetwork As Object
Dim CpmputerName As String
Dim m As Variant
Dim rst As Recordset
'Dim rst1 As Recordset
Set rst = CurrentDb.OpenRecordset("Select Юзер From Заявки WHERE Код = " & Код & "")
'Set rst1 = CurrentDb.OpenRecordset("Select [Заключение ДКР] From Заявки WHERE Код = " & Код & "")
m = Nz(rst.Fields("Юзер").Value)
'ТипЗаключения = Nz(rst1.Fields("Заключение ДКР").Value)
rst.MoveFirst
rst.Close
Set rst = Nothing
'Set rst1 = Nothing
'Определяем Юзера
Set WshNetwork = CreateObject("WScript.Network")
CpmputerName = WshNetwork.ComputerName
Set WshNetwork = Nothing
If m = 0 Then
CurrentProject.Connection.Execute "UPDATE Заявки SET Юзер = '" & CpmputerName & "', ВремяВнесенияЗаписи = '" & TimeValue(Now()) & "', ДатаВнесенияЗаписи = '" & DateValue(Now()) & "' WHERE Код = " & Код & " "
End If
' Херачим историю изменений
' Поставить заплатку на ошибку
On Error GoTo HandleErr
If ТипЗаключения Empty Then
CurrentProject.Connection.Execute "INSERT INTO История" _
& "(Код, СотрудникДКР, Клиент, [Суть Вопроса], Филиал, [Дата КК], [Дата МКК], [Заключение ДКР], Проблемный, [Дата изменениея], [Кто менял], [Кто создал])" _
& "SELECT Код, [ФИО Сотрудника ДКР], [Наименование заемщика], [Суть вопроса, выносимого на КК/МКК], [Филиал или подразделение]," _
& " [Дата КК], [Дата МКК], [Заключение ДКР], [Стал ли заемщик проблемным], Now, '" & CpmputerName & "', Юзер FROM Заявки WHERE (Код = " & Код & " And [ФИО Сотрудника ДКР] Is Not Null And [Заключение ДКР] Is Not Null)"
End If
ExitHere: Exit Sub
HandleErr: MsgBox ("Ошибка!" + Err.Description)
End Sub
Private Sub Заключение_ДКР_GotFocus()
Dim rst1 As Recordset
Set rst1 = CurrentDb.OpenRecordset("Select [Заключение ДКР] From Заявки WHERE Код = " & Код & "")
ТипЗаключения = Nz(rst1.Fields("Заключение ДКР").Value)
Set rst1 = Nothing
Debug.Print ТипЗаключения
If ТипЗаключения = Empty Then
Debug.Print "Пустое значение"
End If
End Sub
Private Sub Form_Current()
Dim i As Long
Dim blnIsLocked As Boolean
blnIsLocked = (DateDiff("d", Nz([Form_подчиненная форма Заявки].Дата_поступления_заявки_в_ДКР, Date), Date) >= 70)
With Me.Section(0).Controls
For i = 0 To Me.Section(0).Controls.Count - 1
With .Item(i)
Select Case .ControlType
Case acTextBox, acComboBox
.Locked = blnIsLocked
Case Else
End Select
End With
Next i
End With
' Отробразить суть вопроса
Form_Заявки.СутьВопроса = Me.Суть_вопроса__выносимого_на_КК_МКК
Form_Заявки.Комментарий = Me.Стал_ли_заемщик_проблемным
Ключ = Nz(Me.Код, 0)
Код.ControlSource = Код.ControlSource
End Sub
Private Sub Form_Load()
Form_FormHistory.КодМаркер = 1
'If Me.Код.Value = DMax(Me.Код.Value) Then
'Me.Код.SetFocus
'End If
DoCmd.GoToRecord acDataForm, "подчиненная форма Заявки", acLast
End Sub
Private Sub Наименование_заемщика_NotInList(NewData As String, Response As Integer)
Dim intNewCategory As Integer, strTitle As String, intMsgDialog As Integer
Dim rs As DAO.Recordset
Dim КакаяФормаЮЛ As String
strTitle = "Такой пункт отсутствует в списке "
intMsgDialog = vbYesNo + vbQuestion + vbDefaultButton1
intNewCategory = MsgBox("Добавить новый пункт?", intMsgDialog, strTitle)
КакаяФормаЮЛ = InputBox("Втавте форму ЮЛ (ООО, ЗАО, ОАО, ИП)")
If intNewCategory = vbYes Then
DoCmd.RunCommand acCmdUndo
Set rs = CurrentDb.OpenRecordset("Компании")
rs.AddNew
rs!Компания = NewData
rs!ФормаЮЛ = КакаяФормаЮЛ
rs.Update
' DoCmd.OpenForm "пунктМ", acNormal, , , acAdd, acDialog, NewData
Response = acDataErrAdded
End If
End Sub
'==========================================================
' Фильтр для Тани по Like 29/04/2014, Крамаренко К.И.
'==========================================================
Sub Filterr()
Dim S1 As String
Dim S2 As String
Me.Refresh
S1 = "true"
S2 = "" & Me.Наименование_заемщика
If Len(S2) > 0 Then
S1 = S1 & " and [Наименование заемщика] In (SELECT [Код] FROM Компании WHERE [Компания] Like '*" & S2 & "*')"
End If
On Error GoTo HandleErr
Me.подчиненная_форма_Заявки.Form.Filter = S1
Me.подчиненная_форма_Заявки.Form.FilterOn = True
Me.Заявки_Запрос_МСБ.Form.Filter = S1
Me.Заявки_Запрос_МСБ.Form.FilterOn = True
ExitHere: Exit Sub
HandleErr: MsgBox ("Ошибка! Ведеите буквы. " + Err.Description)
Resume ExitHere
End Sub
Private Sub Филиал_или_подразделение_AfterUpdate()
Dim ТекСчетчик As Integer
If Not IsNull([Form_подчиненная форма Заявки].Филиал_или_подразделение) Then
ТекСчетчик = DLookup("Счетчик", "Филиалы", "Код = " & [Form_подчиненная форма Заявки].Филиал_или_подразделение & "")
ТекСчетчик = ТекСчетчик + 1
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE Филиалы SET Счетчик = '" & ТекСчетчик & "' WHERE Код = " & [Form_подчиненная форма Заявки].Филиал_или_подразделение & ""
Me.Филиал_или_подразделение.Requery
End If
End Sub
Private Sub ФИО_Сотрудника_ДКР_AfterUpdate()
Dim ТекСчетчик As Integer
If Not IsNull([Form_подчиненная форма Заявки].ФИО_Сотрудника_ДКР) Then
ТекСчетчик = DLookup("Счетчик", "ФИО сотрудника ДКР", "Код = " & [Form_подчиненная форма Заявки].ФИО_Сотрудника_ДКР & "")
ТекСчетчик = ТекСчетчик + 1
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE [ФИО сотрудника ДКР] SET Счетчик = '" & ТекСчетчик & "' WHERE Код = " & [Form_подчиненная форма Заявки].ФИО_Сотрудника_ДКР & ""
Me.ФИО_Сотрудника_ДКР.Requery
End If
End Sub
Private Sub Исполнитель_кредитчик_AfterUpdate()
Dim ТекСчетчик As Integer
If Not IsNull([Form_подчиненная форма Заявки].Исполнитель_кредитчик) Then
ТекСчетчик = DLookup("Счетчик", "ФИО Кредитчики", "Код = " & [Form_подчиненная форма Заявки].Исполнитель_кредитчик & "")
ТекСчетчик = ТекСчетчик + 1
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE [ФИО Кредитчики] SET Счетчик = '" & ТекСчетчик & "' WHERE Код = " & [Form_подчиненная форма Заявки].Исполнитель_кредитчик & ""
Me.Исполнитель_кредитчик.Requery
End If
End Sub
Public Sub ццуцу()
End Sub
--------------------
дудис