Делимся наработками

'---------------------------------------------------------------------------------------
' Procedure : IsTableADO, Release 2.0
' DateTime  : 11.01.2007 16:59
' Author    : DSonnyh
' Purpose   : Проверка наличия таблицы в указанной базе данных
'---------------------------------------------------------------------------------------
'
Public Function IsTableADO(Name As String, strBase As String) As Boolean
' Name - наименование таблицы
' strBase - полный путь к файлу базы
 
    Dim cnn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim tdf As ADOX.Table
   On Error GoTo IsTable_Error_ADO
 
    Set cnn = New ADODB.Connection
    Set cat = New ADOX.Catalog
    
    Dim strProvider As String
' строка подклюбчения
    strProvider = "Provider=Microsoft.Jet.OLEDB.4.0;User ID=;" _
            & "Data Source=" & strBase & ";Mode=Share Deny None;" _
            & "Extended Properties=" & "''" & ";Jet OLEDB:System database=;Jet O"
    
    If strBase = CurrentProject.FullName Then
        cat.ActiveConnection = CurrentProject.Connection
       Else
        cnn.ConnectionString = strProvider
        cnn.Open
        cat.ActiveConnection = cnn.ConnectionString
    End If
        
    IsTableADO = False
    
    For Each tdf In cat.Tables
        If tdf.Name = Name Then
            IsTableADO = True
            Exit For 'Function
        End If
    Next tdf
    
    Set tdf = Nothing
    Set cat = Nothing
    
    If strBase <> CurrentProject.FullName Then
        cnn.Close
    End If
    Set cnn = Nothing
 
   On Error GoTo 0
Exit_IsTable_ADO:
   Exit Function
 
IsTable_Error_ADO:
 
    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре IsTableADO"
    Resume Exit_IsTable_ADO
 
End Function

'---------------------------------------------------------------------------------------
' Procedure : IsTableDAO, Release 2.0
' DateTime  : 15.01.2007 10:39
' Author    : DSonnyh
' Purpose   : Проверка наличия таблицы в указанной базе данных
'---------------------------------------------------------------------------------------
'
Public Function IsTableDAO(Name As String, strBase As String) As Djjlesn
' проверка на наличие определенной таблицы
' Name - наименование таблицы
' strBase - полный путь к файлу базы
   On Error GoTo IsTableDAO_Error
    Dim dbs As Database, tdf As TableDef
    
    If strBase = CurrentDb.Name Then
        Set dbs = CurrentDb
    Else
        Set dbs = DBEngine.Workspaces(0).OpenDatabase(strBase)
    End If
    
    IsTableDAO = False
    For Each tdf In dbs.TableDefs
        If tdf.Name = Name Then
            IsTableDAO = True
            Exit For
        End If
    Next tdf
    Set tdf = Nothing
    dbs.Close
    Set dbs = Nothing
 
   On Error GoTo 0
Exit_IsTableDAO:
   Exit Function
 
IsTableDAO_Error:
 
    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре IsTableDAO"
    Resume Exit_IsTableDAO
 
End Function

Public Function IsTable(ZP_NameTable As String) As Long
' проверка на наличие определенной таблицы
' ZP_NameTable - наименование таблицы
 
    Application.Echo False 'отключаем обновление экрана
    On Error Resume Next
    DoCmd.OpenTable ZP_NameTable
    If Err.Number = 0 Then
        DoCmd.Close acTable, ZP_NameTable
    Else
        IsTable = Err.Number
    End If
    Application.Echo True
     
End Function 'IsTable

Public Function ExistsTable(strNameTable As String, Optional ByRef strResult As String = "") As Byte
On Error Resume Next
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "Insert INTO " & strNameTable & " SELECT * FROM " & strNameTable & " WHERE 0=1"
    Select Case Err.Number
    Case 0
        ExistsTable = 0
        strResult = "Таблица существует"
    Case 3078
        ExistsTable = 1
        strResult = "Таблица отсутствует"
    Case 3024, 3011
        ExistsTable = 2
        strResult = "Не найден файл"
    Case 3044
        ExistsTable = 3
        strResult = "Указан ошибочный путь"
    Case 3343
        ExistsTable = 4
        strResult = "Нераспознаваемый формат базы данных"
    Case 3321
        ExistsTable = 5
        strResult = "Не задана база данных в строке подключения"
    Case Else
        ExistsTable = 6
        strResult = "Неизвестная ошибка"
    End Select
    Err.Clear
    DoCmd.SetWarnings True
End Function

Public Sub Test()
Dim qq As String
    Debug.Print ExistsTable("Код_сотрудников IN 'e:\Проект2007.adp'", qq); Tab; qq
    Debug.Print
    Debug.Print ExistsTable("Код_сотрудников IN 'e:\11\db120000031.mdb'", qq); Tab; qq
    Debug.Print ExistsTable("Код_сотрудников IN 'e:\db120000031.mdb'", qq); Tab; qq
    Debug.Print ExistsTable("Код_сотрудников1 IN 'e:\db12000003.mdb'", qq); Tab; qq
    Debug.Print ExistsTable("Код_сотрудников IN 'e:\db12000003.mdb'", qq); Tab; qq
    Debug.Print
    Debug.Print ExistsTable("PERSONS IN """" [dBASE IV;DATABASE=]", qq); Tab; qq
    Debug.Print ExistsTable("PERSONS IN """" [dBASE IV;DATABASE=e:\Temp\1]", qq); Tab; qq
    Debug.Print ExistsTable("PERSONS1 IN """" [dBASE IV;DATABASE=e:\Temp]", qq); Tab; qq
    Debug.Print ExistsTable("PERSONS IN """" [dBase IV;DATABASE=E:\Temp]", qq); Tab; qq
    Debug.Print
    Debug.Print ExistsTable("Таблица2", qq); Tab; qq
    Debug.Print ExistsTable("Таблица21", qq); Tab; qq
End Sub
 
 4            Нераспознаваемый формат базы данных
 
 3            Указан ошибочный путь
 2            Не найден файл
 1            Таблица отсутствует
 0            Таблица существует
 
 5            Не задана база данных в строке подключения
 3            Указан ошибочный путь
 2            Не найден файл
 0            Таблица существует
 
 0            Таблица существует
 1            Таблица отсутствует

Public Function TableExist(strTableName As String) As Boolean 
Dim db As DAO.Database 
Dim i As Long 
 
TableExist = False 
Set db = CurrentDb 
With db 
  For i = 0 To .TableDefs.Count - 1 
    If .TableDefs(i).name = strTableName Then 
        TableExist = True 
        Exit For 
    End If 
  Next i 
End With 
Set db = Nothing 
End Function

'---------------------------------------------------------------------------------------
' Procedure : listTables
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : вернуть список всех таблиц в базе данных
' Copyright : The following code may be used as you please, but may not be resold, as
'             long as the header (Author, Website & Copyright) remains with the code.
'
' Входные переменные:
' ~~~~~~~~~~~~~~~~
' bShowSys - True/False включать или нет системные таблицы в список
'
' История изменений:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-June-01            Initial Release
'---------------------------------------------------------------------------------------
Function listTables(bShowSys As Boolean) As String
On Error GoTo listTables_Error
    Dim db As DAO.Database
    Dim td As DAO.TableDefs
 
    Set db = CurrentDb()
    Set td = db.TableDefs
    For Each t In td    ' цикл перебора всех таблиц 
        If Left(t.Name, 4) = "MSys" And bShowSys = False Then GoTo Continue
        If Left(t.Name, 1) = "~" And bShowSys = False Then GoTo Continue
        Debug.Print t.Name
Continue:
    Next
 
    Set td = Nothing
    Set db = Nothing
If Err.Number = 0 Then Exit Function
 
listTables_Error:
    MsgBox "MS Access обнаружил следующую ошибку" & vbCrLf & vbCrLf & "Номер ошибки: " & _
    Err.Number & vbCrLf & "Источник ошибки: listTables" & vbCrLf & "Описание ошибки: " & _
    Err.Description, vbCritical, "Произошла ошибка!"
    Exit Function
End Function

Public Function IsFinal(tel As String, txt As String)
'это рабочий вариант
  Dim doc As Object 'HTMLDocument
  If tel = "" Then Exit Function
  If txt = "" Then Exit Function
  
  Set doc = CreateObject("htmlfile")
  txt = Replace(txt, """", "'")
  doc.Body.innerHTML = "<button name=""send"" type=""submit"" onclick=""document.location='whatsapp://send?phone=" & tel & "&text=" & txt & "'"">Переход по ссылке 5</button>"
  doc.All("send").Click
End Function

'---------------------------------------------------------------------------------------
' Procedure : ListXlsSheets
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : перечислить имена листов рабочей книги Excel 
' Copyright : следующее может быть изменено и повторно использовано по вашему желанию, при условии что
'             уведомление об авторских правах остается неизменным (включая автора, веб-сайт и
'             «Авторское право»).  
'
' Входные переменные:
' ~~~~~~~~~~~~~~~~~~~
' sFile - файл Excel для списка листов
'
' Дата выпуска (гггг/мм/дд) Описание:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-Jul-15                 Первоначальный выпуск
'---------------------------------------------------------------------------------------
Function ListXlsSheets(sFile As String)
On Error GoTo Error_Handler
    Dim NumSheets   As Integer
    Dim i           As Integer
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
    Dim xlWrkSht    As Object
 
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") ' Привязать к существующему экземпляру Excel 
 
    If Err.Number <> 0 Then
        ' Не удалось получить экземпляр Excel, поэтому создайте новый
        Err.Clear
        On Error GoTo Error_Handler
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo Error_Handler
    End If
 
    xlApp.Visible = False ' сделать Excel видимым или нет для пользователя
    Set xlWrkBk = xlApp.Workbooks.Open(sFile)
 
    NumSheets = xlWrkBk.Sheets.Count
    For i = 1 To NumSheets
        Debug.Print i & " - " & xlWrkBk.Sheets(i).Name
    Next i
 
    xlWrkBk.Close False
    xlApp.Close
 
    Set xlWrkSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
 
Exit Function
 
Error_Handler:
    If Err.Number <> 438 Then
        MsgBox "MS Access сгенерировал следующую ошибку" & vbCrLf & vbCrLf & "Номер ошибки: " & _
        Err.Number & vbCrLf & "Источник ошибки: ListXlsSheets" & vbCrLf & "Описание ошибки: " & _
        Err.Description, vbCritical, "Произошла ошибка!"
        Exit Function
    Else
        Resume Next
    End If
 
End Function

'---------------------------------------------------------------------------------------
' Procedure : MVF_Find
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Identify table fields that use Complex data types (attachments, MVF)
'               so they can be eliminated!
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
'
' Usage:
' ~~~~~~
' Call MVF_Find
'   Returns -> a listing of fields in the VBE Immediate Window
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2022-12-19              Initial Release
'---------------------------------------------------------------------------------------
Sub MVF_Find()
'https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/field2-iscomplex-property-dao
'https://github.com/MicrosoftDocs/office-developer-client-docs/blob/main/docs/access/desktop-database-reference/datatypeenum-enumeration-dao.md
On Error GoTo Error_Handler
    Dim db                    As DAO.Database
    Dim rs                    As DAO.Recordset
    Dim tbl                   As DAO.TableDef
    Dim fld2                  As DAO.Field2
    Dim sSQL                  As String
 
    sSQL = "SELECT MsysObjects.Name AS [ObjectName]" & vbCrLf & _
           " FROM MsysObjects" & vbCrLf & _
           " WHERE (((MsysObjects.Name Not Like '~*') " & _
           "    AND (MsysObjects.Name Not Like 'MSys*') " & _
           "    AND (MsysObjects.Name Not Like 'f_*'))" & vbCrLf & _
           "    AND (MsysObjects.Type In (1, 6)))" & vbCrLf & _
           " ORDER BY MsysObjects.Name;"
 
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            Do While Not .EOF
                Debug.Print ![ObjectName]
                Debug.Print String(50, "-")
                Set tbl = db.TableDefs(![ObjectName])
                For Each fld2 In tbl.Fields
                    If fld2.IsComplex = True Then 'indicates whether the specified field is a multi-valued data type MVF, Attachment
                        Debug.Print , fld2.Name, FieldTypeName(fld2)
                    End If
                Next fld2
                Debug.Print
                .MoveNext
            Loop
        End If
    End With
     
Error_Handler_Exit:
    On Error Resume Next
    Set tbl = Nothing
    Set fld2 = Nothing
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Sub
  
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Source: MVF_Find" & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub

Function FieldTypeName(fld As DAO.Field) As String
    'Purpose: Converts the numeric results of DAO Field.Type to text.
    'Source/Copyright: Allen Browne
    'URL: http://allenbrowne.com/func-06.html
    Dim strReturn As String    'Name to return
 
    Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.
        Case dbBoolean: strReturn = "Yes/No"            ' 1
        Case dbByte: strReturn = "Byte"                 ' 2
        Case dbInteger: strReturn = "Integer"           ' 3
        Case dbLong                                     ' 4
            If (fld.Attributes And dbAutoIncrField) = 0& Then
                strReturn = "Long Integer"
            Else
                strReturn = "AutoNumber"
            End If
        Case dbCurrency: strReturn = "Currency"         ' 5
        Case dbSingle: strReturn = "Single"             ' 6
        Case dbDouble: strReturn = "Double"             ' 7
        Case dbDate: strReturn = "Date/Time"            ' 8
        Case dbBinary: strReturn = "Binary"             ' 9 (no interface)
        Case dbText                                     '10
            If (fld.Attributes And dbFixedField) = 0& Then
                strReturn = "Text"
            Else
                strReturn = "Text (fixed width)"        '(no interface)
            End If
        Case dbLongBinary: strReturn = "OLE Object"     '11
        Case dbMemo                                     '12
            If (fld.Attributes And dbHyperlinkField) = 0& Then
                strReturn = "Memo"
            Else
                strReturn = "Hyperlink"
            End If
        Case dbGUID: strReturn = "GUID"                 '15
 
        'Attached tables only: cannot create these in JET.
        Case dbBigInt: strReturn = "Big Integer"        '16
        Case dbVarBinary: strReturn = "VarBinary"       '17
        Case dbChar: strReturn = "Char"                 '18
        Case dbNumeric: strReturn = "Numeric"           '19
        Case dbDecimal: strReturn = "Decimal"           '20
        Case dbFloat: strReturn = "Float"               '21
        Case dbTime: strReturn = "Time"                 '22
        Case dbTimeStamp: strReturn = "Time Stamp"      '23
 
        'Constants for complex types don't work prior to Access 2007 and later.
        Case 101&: strReturn = "Attachment"         'dbAttachment
        Case 102&: strReturn = "Complex Byte"       'dbComplexByte
        Case 103&: strReturn = "Complex Integer"    'dbComplexInteger
        Case 104&: strReturn = "Complex Long"       'dbComplexLong
        Case 105&: strReturn = "Complex Single"     'dbComplexSingle
        Case 106&: strReturn = "Complex Double"     'dbComplexDouble
        Case 107&: strReturn = "Complex GUID"       'dbComplexGUID
        Case 108&: strReturn = "Complex Decimal"    'dbComplexDecimal
        Case 109&: strReturn = "Complex Text"       'dbComplexText
        Case Else: strReturn = "Field type " & fld.Type & " unknown"
    End Select
 
    FieldTypeName = strReturn
End Function

Call MVF_Find

Function CloseAllOpenReports() As Boolean
 
    On Error GoTo Error_CloseAllOpenReports
    
    Dim objRpts               As Object
    Dim objRpt                As Access.Report
    Dim strRptName()          As String
    Dim lngRptCount           As Long
    Dim i                     As Long
 
    Set objRpts = Application.Reports
    lngRptCount = objRpts.Count
    ReDim strRptName(lngRptCount)
 
    For Each objRpt In objRpts
        i = i + 1
        strRptName(i) = objRpt.Name
    Next objRpt
    
    For i = 1 To lngRptCount
        DoCmd.Close acReport, strRptName(i), acSaveNo
    Next i
    
    CloseAllOpenReports = True
 
Error_CloseAllOpenReports_Exit:
 
    On Error Resume Next
    
    Set objRpt = Nothing
    Set objRpts = Nothing
    
    Exit Function
 
Error_CloseAllOpenReports:
    
    MsgBox "Error Function: CloseAllOpenReports" & vbCrLf & _
           "Error Number: " & err.Number & vbCrLf & _
           "Error Description: " & err.Description
    
    Resume Error_CloseAllOpenReports_Exit
 
End Function

'---------------------------------------------------------------------------------------
' Procedure : CloseAllOpenReports
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Close all the currently open Reports in the database
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
'
' Usage:
' ~~~~~~
' ? CloseAllOpenReports
'   Returns -> True     => Closed all Reports successfully
'              False    => A problem occurred
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2015-02-17              Initial Release
' 2         2023-02-09              Update variable naming, Error handler, copyright
' 3         2023-03-13              Changed approach as For each rpt in Reports skips
'                                       objects
'---------------------------------------------------------------------------------------
Function CloseAllOpenReports() As Boolean
    On Error GoTo Error_Handler
    Dim i                     As Long
 
    For i = Application.Reports.Count - 1 To 0 Step -1
        DoCmd.Close acReport, Reports(i).Name, acSaveNo
    Next i
 
    CloseAllOpenReports = True
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Source: CloseAllOpenReports" & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

Call CloseAllOpenReports

If CloseAllOpenReports = True Then
    '...
End If

'---------------------------------------------------------------------------------------
' Procedure : CloseAllOpenForms
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Close all the currently open Forms in the database
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
'
' Usage:
' ~~~~~~
' ? CloseAllOpenForms
'   Returns -> True     => Closed all Forms successfully
'              False    => A problem occurred
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2015-02-17              Initial Release
' 2         2023-02-09              Update variable naming, Error handler, copyright
' 3         2023-03-13              Changed approach as For each frm in frms skips
'                                       objects
'---------------------------------------------------------------------------------------
Function CloseAllOpenForms() As Boolean
    On Error GoTo Error_Handler
    Dim i As Long
 
    For i = Application.Forms.Count - 1 To 0 Step -1
        DoCmd.Close acForm, Forms(i).Name, acSaveNo
    Next i
    
    CloseAllOpenForms = True
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Source: CloseAllOpenForms" & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

Function CloseAllOpenForms() As Boolean
    On Error GoTo Error_CloseAllOpenForms
    
    Dim objFrms               As Object
    Dim objFrm                As Access.Form
    Dim strFormName()         As String
    Dim lngFormCount          As Long
    Dim i                     As Long
 
    Set objFrms = Application.Forms    'Collection of all the open forms
    lngFormCount = objFrms.Count
    ReDim strFormName(lngFormCount)
    
    For Each objFrm In objFrms    'Loop all the forms
        i = i + 1
        strFormName(i) = objFrm.Name
    Next objFrm
    
    For i = 1 To lngFormCount
        DoCmd.Close acForm, strFormName(i), acSaveNo
    Next i
    
    CloseAllOpenForms = True
 
Error_CloseAllOpenForms_Exit:
    On Error Resume Next
    Set objFrm = Nothing
    Set objFrms = Nothing
    Exit Function
 
Error_CloseAllOpenForms:
    MsgBox "Error Function: CloseAllOpenForms" & vbCrLf & _
           "Error Number: " & err.Number & vbCrLf & _
           "Error Description: " & err.Description
    Resume Error_CloseAllOpenForms_Exit
End Function

Call CloseAllOpenForms

If CloseAllOpenForms= True Then
    '...
End If