В этом случае придется немного по программировать. Для начала уберем у полей рамку. Добавим одну линию в конце нашей записи — lineEndRow. Вертикальные линии будем рисовать самостоятельно методом Report.Line меду началом секции «Область данных» и линией lineEndRow. Функцию ниже нужно вызывать из события ОбластьДанных_Print.

Вот реализация функции и живет она у меня в модуле mc_report:

Public Sub ReportPrintTable(ByRef lineEndRow As Line _
                            , Optional ByVal lColor As Long = 3355443)
' печать вертикальных линий
    Dim ctl As Control
    Dim sct As Section
    Dim lHeight As Long
    Dim rpt As Report

    Set rpt = lineEndRow.Parent

    Set sct = rpt.Section(acDetail)
    rpt.DrawWidth = 1

    lHeight = lineEndRow.Top
    For Each ctl In sct.Controls
        If ctl.ControlType = acTextBox Then
            rpt.Line (ctl.Left, ctl.Top)-Step(0, lHeight - 2), lColor
            rpt.Line (ctl.Left + ctl.Width, ctl.Top)-Step(0, lHeight - 2), lColor
        End If
    Next ctl
End Sub

Как это работает можно увидеть в примере.

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Для изменения параметров из коллекций типа CurrentDb.Parametrs я написал функцию VC_PropertyChange(), которая располагается в модуле mc_objects.

Dim stAppTitle as String
dim stPathToIco as String

'-- изменить название приложения
Call mc_objects.VC_PropertyChange(CurrentDb, "AppTitle", dbText, stAppTitle)
'-- изменить иконку по умолчанию
Call mc_objects.VC_PropertyChange(CurrentDb, "AppIcon", dbText, stPathToIco)
Call mc_objects.VC_PropertyChange(CurrentDb, "UseAppIconForFrmRpt", dbBoolean, True)
'-- отобразить изменения
Application.RefreshTitleBar

Также в модуле mc_objects располагается еще одна полезная функция VC_PropertyValue(), которая читает значения параметра:

Dim stMenu As String
'-- получить меню по умолчанию
stMenu = VC_PropertyValue(CurrentDb, "StartUpMenuBar")

Текст функций:

Public Sub CM_PropertyChange(ByRef obj As Object _
                                , ByVal imProperty As String _
                                , ByVal vPropertyType As Variant _
                                , ByVal vPropertyValue As Variant)
' 2007-03-17 Скоков С.А.
' Изменить свойства (Properties) объекта. Если свойства нет, то оно добавляется.
On Error GoTo Err_
    Dim prp As DAO.Property
    Const c_ErrorPropNotFound = 3270

    obj.Properties(imProperty) = vPropertyValue
    CM_PropertyChange = True

Exit_:
    Exit Sub

Err_:
    If Err.Number = c_ErrorPropNotFound Then     '-- Property not found.
        Set prp = obj.CreateProperty(imProperty, vPropertyType, vPropertyValue)
        obj.Properties.Append prp
        Resume Next
    Else '-- Unknown error.
	Err.Raise vbObjectError + 1, "CM_PropertyChange()->" & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    End If
End Sub

Public Function CM_PropertyValue(ByRef obj As Object _
                                , ByVal imProperty As String) As Variant
' 2007-03-17 Скоков С.А.
' Изменить свойства (Properties) объекта. Если свойства нет, то оно добавляется.
On Error GoTo Err_
    Dim prp As DAO.Property
    Const c_ErrorPropNotFound = 3270

    Set prp = obj.Properties(imProperty)

    CM_PropertyValue = prp.Value

Exit_:
    Exit Function

Err_:
    If Err.Number = c_ErrorPropNotFound Then     '-- Property not found.
    Else '-- Unknown error.
        Err.Raise vbObjectError + 1, "CM_PropertyValue()->" & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    End If
End Function

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Очень замечательная книга. Уже давно прочитал ее. Расскрывает многие принципы хорошего подхода к программированию. Рекомендую к прочтению.

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Что нужно сделать:

• Создать новую форму.
• Убрать область выделения, полосы прокрутки, область выбора записей.
• Разместить в области данных элемент управления в левом верхнем углу. Назовем его f_spis_. Элементом управления может быть любой тип. Я чаще использую для подобных случаев подчиненную форму в табличном виде. Элемент управления можно размещать и в заголовке или примечании формы, но в этом случае элемент управления будет меняться только по ширине.
• Создать событие формы «Изменение размера» следующего вида:

Private Sub Form_Resize()
    Call mc_Form.VC_ResizeCtl(Me.f_spis_)
End Sub

Код функций:

Public Sub VC_ResizeCtl(ByRef ctl As Control)
' Скоков С.А. 2006-12-16
' Изменяет размер элемента управления под оконные размеры формы.
' функция должна вызываться на событие Form_Resize()
' Элемент управления должен находится в области данных.
' Предполагается что он один и должен занимать всю облатсь данных.
' 0.6 * c_lTvipInSm и 1 * c_lTvipInSm константы, определенные опытным путем,
' чтобы элемент управления не прилипал к правой и ниженй части формы
On Error GoTo Err_
    Dim frm As Form
    Dim lCtlWidth As Long, lCtlHeight As Long
    Dim lDetailHeight As Long

    Set frm = ctl.Parent
    '-- изменение размеров "поверхности" формы
    frm.Width = frm.WindowWidth
    lDetailHeight = frm.WindowHeight - frm.Section(acHeader).Height - frm.Section(acFooter).Height
    '-- если форму свернуть, то произойдет ошибка
    If lDetailHeight < 0 Then
        Exit Sub
    End If

    frm.Section(acDetail).Height = lDetailHeight
    '-- изменение размеров элемента управления
    lCtlWidth = frm.WindowWidth - ctl.Left * 2 - 0.4 * c_lTvipInSm
    lCtlHeight = frm.WindowHeight - ctl.Top * 2 - 1 * c_lTvipInSm _
                - frm.Section(acHeader).Height - frm.Section(acFooter).Height

    If lCtlWidth > c_lTvipInSm Then ctl.Width = lCtlWidth
    If lCtlHeight > c_lTvipInSm Then ctl.Height = lCtlHeight
Exit_:
    Exit Sub
Err_:
    MsgBox Err.Description
    Resume Exit_
    Resume
End Sub

Public Sub CM_ResizeWidth(ByRef frm As Form, ByRef ctl As Control)
' Скоков С.А. 2008-03-12
' Изменяет размер элемента управления под оконные размеры формы по ШИРИНЕ.
' функция должна вызываться на событие Form_Resize()
' Элемент управления должен находится в области данных.
' Предполагается что он один и должен занимать всю облатсь данных.
' 0.6 * c_lTvipInSm и 1 * c_lTvipInSm константы, определенные опытным путем,
' чтобы элемент управления не прилипал к правой и ниженй части формы
On Error GoTo Err_
    Const c_lTvipInSm As Long = 567

    Dim lCtlWidth As Long, lCtlHeight As Long

    '-- изменение размеров элемента управления
    lCtlWidth = frm.WindowWidth - ctl.Left - 0.6 * c_lTvipInSm

    If lCtlWidth > c_lTvipInSm Then ctl.Width = lCtlWidth
Exit_:
    Exit Sub
Err_:
    MsgBox Err.Description
    Resume Exit_
End Sub

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

У меня временная база пересоздается каждый раз при запуске программы. Функция копирует шаблоны временных таблиц из интерфейсной базы, имя которых подходит под условие: temp_*_def. Например, temp_import_def.

Текст функции:

Public Sub CM_CreateTempMDB()
' Скоков С.А. 2007-04-02
' Создание временной БД. Временные таблицы в текущей БД должны соответствовать формату temp_*_def.
' Подлинковываться в текущую БД они будут с именами temp_*
' внешние модули: mc_LT, mc_File, mc_StrSost
On Error GoTo Err_
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim pathToDb As String

    Call mc_StrSost.CM_StrSost("Создание временного файла")

    '-- создание БД
    pathToDb = mc_File.CM_GetDBPath & "temp.mdb"

    If Dir(pathToDb) <> "" Then
        Call Kill(pathToDb)
    End If

    Set db = CreateDatabase(pathToDb, dbLangGeneral)
    db.Close

    '-- копирование таблиц во временную БД
    Set db = CurrentDb

    For Each tdf In db.TableDefs
        If tdf.Name Like "temp_*_def" Then
            DoCmd.CopyObject pathToDb, Left(tdf.Name, Len(tdf.Name) - 4), acTable, tdf.Name
        End If
    Next

    '-- линковка временных таблиц
    mc_LT.CM_LT_AddAllExt (pathToDb)
Exit_:
    Call mc_StrSost.CM_StrSost
    Exit Sub
Err_:
    Err.Raise Err.Number, "CM_CreateTempMDB()->" & Err.Source, Err.Description
    Resume Exit_
End Sub

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Их всего три:

• CM_LT_AddAllExt() — добавляет в текущую базу ссылки на таблицы из mdb файла
• CM_LT_AddAllExt_ODBC() — добавляет в текущую базу ссылки на ODBC таблицы на сервере
• CM_LT_DelAll() — удаляет таблицы-ссылки из текущей базы

Они позволяют создать в интерфейсной базе ссылки на таблицы из базы с данным. У меня они запускаются каждый раз при запуске. Написаны они давным давно, но полезны до сих пор.

Текст функций:

Public Function CM_LT_AddAllExt(ByVal stPathToBase As String) As Long
' <Скоков С.А.> создана: 2004-02-05
' подлинковывает все таблицы из указанной базы
' проверяет существует ли подлинковываемая таблица в текущей как ссылка, то обновляется строка подключения.
' если же в тек. базе есть таблица с таким именем (не ссылка), то подлинковываемая таблица пропускается
' т.о. перед вызовом этой функции удалять линкованные таблицы не нужно
' вход: stPathToBase - путь и имя базы
' выход: количество не подлинкованных таблиц, в случае ошибки возвращает -1

On Error GoTo Err_
    CM_LT_AddAllExt = 0

    Dim tdf As TableDef
    Dim db As Database
    Dim bIsSysOrLink As Boolean
    Dim stNameTbl As String
    Dim lCountNotLinket As Long ' количество не подлинкованных таблиц
    Dim stConnect As String
    Dim dbCur As DAO.Database
    Dim tdfNew As DAO.TableDef
    Dim tdfsCur As DAO.TableDefs

    stConnect = ";DATABASE=" & stPathToBase
    Set dbCur = CurrentDb
    Set tdfsCur = dbCur.TableDefs

    '-- делаем масив таблиц в текущей базе
    Dim masNameTbl() As String
    Dim i As Long

    tdfsCur.Refresh
    ReDim masNameTbl(tdfsCur.count - 1)
    i = 0
    For Each tdf In tdfsCur
        masNameTbl(i) = tdf.Name
        i = i + 1
    Next tdf

    '-- коннектимся к базе
    Set db = OpenDatabase(stPathToBase)

    lCountNotLinket = 0
    '-- линкуем
    For Each tdf In db.TableDefs
        bIsSysOrLink = (tdf.Attributes And dbSystemObject) Or _
                    (tdf.Attributes And dbHiddenObject) _
                    Or (tdf.Attributes And dbAttachedTable) ' системная или присеоединенная ли?

        If Not bIsSysOrLink Then  ' если не то что выше, то можно делать линк
            stNameTbl = tdf.Name
            '-- если такая таблица существует в текущей базе
            If SerchStrInMas(masNameTbl, stNameTbl) <> -1 Then
                '-- то проверяем подлинкованая ли? иначе пропускаем эту таблицу и переходим на следующую
                If (tdfsCur(stNameTbl).Attributes And dbAttachedTable) Then
                    '-- обновляем путь к бд
                    tdfsCur(stNameTbl).Connect = stConnect
                    tdfsCur(stNameTbl).RefreshLink
                Else
                    Debug.Print "CM_LT_AddAllExt(), пропущена таблица:", stNameTbl
                    lCountNotLinket = lCountNotLinket + 1
                End If
            Else
				'-- не существует - то линкуем
                Set tdfNew = dbCur.CreateTableDef(stNameTbl)
                tdfNew.SourceTableName = stNameTbl
                tdfNew.Connect = stConnect
                tdfsCur.Append tdfNew
            End If
        End If
    Next tdf

    db.Close
    Set db = Nothing

    tdfsCur.Refresh
    Set tdfsCur = Nothing
    Set dbCur = Nothing

    CM_LT_AddAllExt = lCountNotLinket
Exit_:
    Exit Function

Err_:
    CM_LT_AddAllExt = -1
	Err.Raise Err.Number, "CM_LT_AddAllExt()->" & Err.Source, Err.Description '-- передаем ошибку в вызвавшую функцию

    Resume Exit_
End Function

Private Function SerchStrInMas(ByRef masStr() As String, ByRef SerchStr As String) As Long
' <Скоков С.А.> создана: 2004-02-05

' Поиск строки в строковом массиве
' вход: masStr - массив строк
'       SerchStr - искомая строка
' выход:
'   номер элемента массива, в котором была найдена подстрока SerchStr, иначе -1 (когда нет совпадений)
'   при ошибке возвращает -1

On Error GoTo Err_

    Dim i As Long

    SerchStrInMas = -1

    For i = LBound(masStr) To UBound(masStr)
        If masStr(i) = SerchStr Then
            SerchStrInMas = i
            Exit For
        End If
    Next i

Exit_:
    Exit Function
Err_:
    SerchStrInMas = -1
    Resume Exit_
End Function

Public Function CM_LT_AddAllExt_ODBC(ByVal stConnectStr As String) As Long
' <Кулага С.Ю.> создана: 2006-10-12

'   подлинковывает все таблицы из указанной базы
'   проверяет существует ли подлинковываемая таблица в текущей как ссылка, то удаляет.
'   если же это является таблицей, то подлинковываемая таблица пропускается
'   т.е. перед вызовом этой функции удалять линкованные таблицы не нужно, он удалить необходимые сама
' вход: stConnectStr - строка подключения ADO
' выход: количество не подлинкованных таблиц, в случае ошибки возвращает -1

On Error GoTo Err_
    CM_LT_AddAllExt_ODBC = 0

    Dim bIsSysOrLink As Boolean
    Dim stNameTbl As String
    Dim tdf As TableDef
    Dim lCountNotLinket As Long ' количество не подлинкованных таблиц
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim stConnectTbl As String
    Dim dbCur As DAO.Database
    Dim tdfNew As DAO.TableDef
    Dim tdfsCur As DAO.TableDefs

    stConnectTbl = "ODBC;" & stConnectStr
    Set dbCur = CurrentDb
    Set tdfsCur = dbCur.TableDefs

    ' делаем масив таблиц в текущей базе
    Dim masNameTbl() As String
    Dim i As Long

    ReDim masNameTbl(tdfsCur.count - 1)
    i = 0
    For Each tdf In tdfsCur
        masNameTbl(i) = tdf.Name
        i = i + 1
    Next tdf

    ' коннектимся к базе
    Set cnn = New ADODB.Connection
    cnn.Open (stConnectStr)
    Set rst = cnn.OpenSchema(adSchemaTables)

    lCountNotLinket = 0
    ' линкуем
    Do While Not rst.EOF
        stNameTbl = rst("TABLE_NAME")
        ' если такая таблица существует в текущей базе
        If SerchStrInMas(masNameTbl, stNameTbl) <> -1 Then
            ' то проверяем линкованая ли? иначе пропусаем эту таблицу и переходим на следующую
            If (tdfsCur(stNameTbl).Attributes And (dbAttachedTable + dbAttachedODBC)) Then
                '-- обновляем путь к бд
                tdfsCur(stNameTbl).Connect = stConnectTbl
                tdfsCur(stNameTbl).RefreshLink
            Else
                Debug.Print "CM_LT_AddAllExt_ODBC(), пропущена таблица:", stNameTbl
                lCountNotLinket = lCountNotLinket + 1
            End If
        Else
			'-- не существует - то линкуем
            Set tdfNew = dbCur.CreateTableDef(stNameTbl)
            tdfNew.SourceTableName = stNameTbl
            tdfNew.Connect = stConnectTbl
            tdfsCur.Append tdfNew
        End If
        rst.MoveNext
    Loop

    tdfsCur.Refresh
    Set tdfsCur = Nothing
    Set dbCur = Nothing

    rst.Close
    cnn.Close
    CM_LT_AddAllExt_ODBC = lCountNotLinket

Exit_:
    Exit Function

Err_:
    Err.Raise Err.Number, "CM_LT_AddAllExt_ODBC()->" & Err.Source, Err.Description '-- передаем ошибку в вызвавшую функцию
    CM_LT_AddAllExt_ODBC = -1
    Resume Exit_
End Function

Public Function CM_LT_DelAll() As Boolean
' <Скоков С.А.> создана: 2003-12-12

' удаляет все связаные таблицы в текущей базе

On Error GoTo Err_

    Dim tdf As TableDef
    Dim db As Database
    Dim bIsAttached As Boolean

    Set db = CurrentDb

    For Each tdf In db.TableDefs
        bIsAttached = (tdf.Attributes And dbAttachedODBC) _
                Or (tdf.Attributes And dbAttachedTable) ' присеоединенная таблица обыкновенная или ODBC

        If bIsAttached Then ' удаляем только прилинкованные
            DoCmd.DeleteObject acTable, tdf.Name
        End If
    Next

    Set db = Nothing
    CM_LT_DelAll = True
Exit_:
    Exit Function
Err_:
    CM_LT_DelAll = False

	Err.Raise Err.Number, "CM_LT_DelAll()->" & Err.Source, Err.Description '-- передаем ошибку в вызвавшую функцию
    Resume Exit_
End Function

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Function CM_GetDBPath() As String
    Dim db As Database

    With CurrentDb
        CM_GetDBPath = Left(.Name, Len(.Name) - Len(Dir(.Name)))
    End With
End Function

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Источником данных для такого запроса может служить такой запрос:

SELECT K_MES, T_MES FROM s_mes;

Атрибуты настроены так:

• Макет
  
• Данные
  

Рассмотрим пример чтения текущего выбранного значения:

    Dim iMes As Integer '-- номер месяца
    Dim stMes As String '-- имя месяца

    '-- значение присоединенного столбца
    iMes = nz(Me.P_K_MES, 0)
    iMes = nz(Me.P_K_MES.Value, 0)
    iMes = nz(Me.P_K_MES.Column(0), 0)

    '-- значение произвольной колонки
    stMes = nz(Me.P_K_MES.Column(1), "Не выбрано")

    MsgBox "Выбранные значения: Номер - " & iMes & ", Название - " & stMes & ".", vbInformation

Первое на что стоит обратить внимание это то, что мы всегда можем прочитать значение колонок только выбранной строчки. Если ничего не выбрано и нет значения по умолчанию, то атрибуты Value и Column вернут Null.

Как Вы заметили, к значению присоединенного столбца можно обратиться двумя способами при помощи Value и Column. Колонки нумеруются с 0, в порядке следования полей в запросе. Но в атрибутах нумерация с 1-ы. Пример скачать тут.

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

Всего получилось три функции для работы с прогресс баром:

• CM_PrBarStart() — инициализировать прогресс бар
• CM_PrBarStep() — изменить прогресс бар
• CM_PrBarEnd() — убрать прогресс бар

И одна функция для работы со строкой состояния:

• CM_StrSost()

Что бы это все заработало необходимо что бы строка состояния была включена (см. параметры запуска).

Код функций:

Public Sub CM_PrBarStart(ByRef stText As String, ByVal lMaxVal As Long)
' инициализация прогресс бара
    DoEvents
    SysCmd acSysCmdInitMeter, stText, lMaxVal
End Sub

Public Sub CM_PrBarStep(ByRef lNextVal As Long)
' увеличение строки прогресса
    DoEvents
    SysCmd acSysCmdUpdateMeter, lNextVal
End Sub

Public Sub CM_PrBarEnd()
' удаление прогресс бара
    DoEvents
    SysCmd (acSysCmdRemoveMeter)
End Sub

Public Function CM_StrSost(Optional stText As String = "")
' Изменяет строку сотояния, если текст не передан, строка состояния очищается
    DoEvents

    If stText = "" Then
        SysCmd acSysCmdClearStatus
    Else
        SysCmd acSysCmdSetStatus, stText
    End If
End Function

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.

• CM_LogMsg() — записать сообщение
• CM_LogErrForm() — записать сообщение об ошибке в форме
• CM_LogErr() — записать сообщение об ошибке
• CM_LogCheckSize() — проверяет размер файла лога. Обычно используется только при запуске приложения.
• CM_LogGetPathFile() — формирует путь к файлу лога
• CM_LogErrDAO() — записать ошибки, возникшие при работе с данными. Только при использовании библиотеки DAO.

«Живут» эти функции в модуле: mc_Log.

Текст функций:

' функции для ведения лога в текстовый файл

'-- имя файла лога
Private Const c_imFileLog As String = "Log.txt"

Public Sub CM_LogMsg(ByRef stMsg As String)
' <Скоков С.А.> 2005-04-05

' запись в файл сообщения
' вход:
'       stMsg - строка сообщения

On Error Resume Next '-- нет обработки ошибок

    Dim iNomFile As Integer

    '-- получаем свободный номер файла
    iNomFile = FreeFile

    Open CM_LogGetPathFile() For Append As #iNomFile
    Print #iNomFile, "m"; Spc(1); Date; Spc(1); Time; Spc(1); stMsg
    Close #iNomFile
End Sub

Public Sub CM_LogErrForm(ByRef frm As Form _
                , ByVal imFunc As String _
                , Optional ErrNom As Variant _
                , Optional ErrDescription As Variant)
' <Скоков С.А.> 2010-03-28

    If frm Is Nothing Then
        imFunc = "Nothing::" & imFunc
    Else
        imFunc = frm.Name & "::" & imFunc
    End If

    Call CM_LogErr(imFunc, ErrNom, ErrDescription)
End Sub

Public Sub CM_LogErr(ByRef imFunc As String _
                , Optional ErrNom As Variant _
                , Optional ErrDescription As Variant)
' <Скоков С.А.> 2005-04-05

' запись в файл сообщения об ошибке
' вход:
'       imFunc - имя функции
'       ErrNom - номер ошибки. если пропущено, то данные берутся из Err.Nuber
'       ErrDescription - строка сообщения/описания ошибки
'                        если пропущено, то данные берутся из Err.Description

    Dim iNomFile As Integer

    '-- обработка входных параметров
    If IsMissing(ErrNom) Then
        ErrNom = Err.Number
    End If

    If IsMissing(ErrDescription) Then
        ErrDescription = Err.Description
    End If

On Error Resume Next '-- нет обработки ошибок

    '-- получаем свободный номер файла
    iNomFile = FreeFile

    Open CM_LogGetPathFile() For Append As #iNomFile
    Print #iNomFile, "e"; Spc(1); Date; Spc(1); Time; Spc(1); _
                    imFunc; Spc(1); "Err: "; ErrNom; Spc(1); ErrDescription
    Close #iNomFile
End Sub

Public Sub CM_LogCheckSize(Optional ByVal lLenMax As Double = 1048576)
' Скоков С.А. 2006-12-07
' проверяет размер файла лога и удаляет если он превышает лимит
' lLenMax - максимальная длинна файла, по умолчанию 1 Мб
    Dim oFSO As Object, oFile As Object
    Dim stPathFile As String

    stPathFile = CM_LogGetPathFile()

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFile = oFSO.GetFile(stPathFile)

    If oFile.Size >= lLenMax Then
        Kill stPathFile
    End If
End Sub

Public Function CM_LogGetPathFile() As String
' Скоков С.А. 2006-12-07
' возвращает путь с именем файла лога
    Dim Db As DAO.Database

    Set Db = CurrentDb
    CM_LogGetPathFile = Left(Db.Name, Len(Db.Name) - Len(Dir(Db.Name))) + c_imFileLog
End Function

Public Sub CM_LogErrDAO(ByRef imFunc As String, Optional ByRef errs As DAO.Errors = Nothing)
' <Скоков С.А.> 2006-12-07

' запись в файл сообщения об ошибке
' вход:
'       imFunc - имя функции
'       ErrNom - номер ошибки. если пропущено, то данные берутся из Err.Nuber
'       ErrDescription - строка сообщения/описания ошибки
'                        если пропущено, то данные берутся из Err.Description
'

On Error Resume Next '-- нет обработки ошибок
    Dim iNomFile As Integer
    Dim errTek As DAO.Error
    '-- получаем свободный номер файла
    iNomFile = FreeFile

    If errs Is Nothing Then
        Set errs = DAO.Errors
    End If

    Open mc_Log.CM_LogGetPathFile() For Append As #iNomFile
    For Each errTek In errs
        Print #iNomFile, "e"; Spc(1); Date; Spc(1); Time; Spc(1); _
                        imFunc; Spc(1); errTek.Source; " Err: "; errTek.Number; Spc(1); errTek.Description
    Next errTek
    Close #iNomFile
End Sub

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.