Инструменты разработчика Access. Библиотека программ, надстроек и справочного материала

Application.FollowHyperlink "https://www.google.com/maps/place/" & strAddress

'---------------------------------------------------------------------------------------
' Procedure : GetHostNameIP
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Retrieve the IP Address of a given host name
' 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: Late Binding  -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sHostName : Host name to lookup the IP address of
'
' Usage:
' ~~~~~~
' GetHostNameIP("utteraccess.com")
'   Returns -> 52.40.49.196
' GetHostNameIP("google.com")
'   Returns -> 2607:f8b0:4006:813::200e,172.217.10.238
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2020-07-20              Initial Release, Forum Help
' 2         2020-07-20              Update to handle the case of multiple addresses
' 3         2020-07-21              Handle blank/empty sHostName calls
'---------------------------------------------------------------------------------------
Function GetHostNameIP(ByVal sHostName As String) As String
    Dim sResult               As String
    Dim aResult               As Variant
    Dim i                     As Long
 
    On Error GoTo Error_Handler
 
    If Len(Trim(sHostName)) = 0 Then GoTo Error_Handler_Exit
 
    sResult = CreateObject("Wscript.Shell").Exec("nslookup " & sHostName).StdOut.ReadAll
    aResult = Split(sResult, vbCrLf)
    If UBound(aResult) > 2 Then
        For i = 4 To UBound(aResult)
            If Len(Trim(aResult(i) & vbNullString)) > 0 Then
                GetHostNameIP = GetHostNameIP & Trim(Replace(Replace(Replace(aResult(i), "Address:", ""), _
                "Addresses:", ""), vbTab, "")) & ","
            End If
        Next i
        If Right(GetHostNameIP, 1) = "," Then GetHostNameIP = Left(GetHostNameIP, Len(GetHostNameIP) - 1)
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetHostNameIP" & 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

'---------------------------------------------------------------------------------------
' Procedure : GetHostNameIP
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Retrieve the IP Address of a given host name
' 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: Late Binding  -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sHostName : Host name to lookup the IP address of
'
' Usage:
' ~~~~~~
' GetHostNameIP("utteraccess.com")
'   Returns -> 52.40.49.196
' GetHostNameIP("google.com")
'   Returns -> 2607:f8b0:4006:813::200e,172.217.10.238
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2020-07-20              Initial Release
'                                       Different approach to avoid screen flashing
' 2         2020-07-21              Handle blank/empty sHostName calls
'---------------------------------------------------------------------------------------
Function GetHostNameIP(ByVal sHostName As String) As String
    Dim sFile                 As String
    Dim sResult               As String
    Dim aResult               As Variant
    Dim i                     As Long
 
    On Error GoTo Error_Handler
 
    If Len(Trim(sHostName)) = 0 Then GoTo Error_Handler_Exit
 
    sFile = Environ("temp") & "\GetHostNameIP.txt"
    'Run the nslookup command and save its results to a text file
    CreateObject("Wscript.Shell").Run "cmd /c nslookup " & sHostName & " > " & sFile, 0, True
    With CreateObject("Scripting.FileSystemObject")
        'Read the contents of the text file into memory
        sResult = .OpenTextFile(sFile).ReadAll()
        'Delete the text file
        .DeleteFile sFile
    End With
    aResult = Split(sResult, vbCrLf)
    If UBound(aResult) > 2 Then
        For i = 4 To UBound(aResult)
            If Len(Trim(aResult(i) & vbNullString)) & 0 Then
                GetHostNameIP = GetHostNameIP & Trim(Replace(Replace(Replace(aResult(i), "Address:", ""), _
                "Addresses:", ""), vbTab, "")) & ","
            End If
        Next i
        If Right(GetHostNameIP, 1) = "," Then GetHostNameIP = Left(GetHostNameIP, Len(GetHostNameIP) - 1)
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetHostNameIP" & 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

'32-bit declaration
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, _
                                                                        ByVal wMsg As Long, _
                                                                        ByVal wParam As Long, _
                                                                        ByVal lParam As Any) As Long
'64-bit declaration
'Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, _
'                                                                                ByVal wMsg As Long, _
'                                                                                ByVal wParam As LongPtr, _
'                                                                                lParam As Any) As LongPtr
 
'---------------------------------------------------------------------------------------
' Procedure : MonitorPower
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Turn On/Off the monitor
' 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
' Req'd     : SendMessage API Declaration
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' bMontiorOn: True -> Turn monitor on
'             False -> Turn monitor off
'
' Usage:
' ~~~~~~
' Call MonitorPower
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2018-12-14              Initial Release (Forum help)
'---------------------------------------------------------------------------------------
Public Function MonitorPower(Optional bMontiorOn As Boolean = False)
'REF: https://docs.microsoft.com/en-us/windows/desktop/menurc/wm-syscommand
    Const WM_SYSCOMMAND = &H112
    Const SC_MONITORPOWER = &HF170&
    Const MONITOR_ON = -1&
    Const MONITOR_OFF = 2&
 
    On Error GoTo Error_Handler
 
    If bMontiorOn = False Then
        SendMessage Application.hWndAccessApp, WM_SYSCOMMAND, SC_MONITORPOWER, MONITOR_OFF
    Else
        SendMessage Application.hWndAccessApp, WM_SYSCOMMAND, SC_MONITORPOWER, MONITOR_ON
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: MonitorPower" & 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

Option Compare Database
Option Explicit
 
'Встроенный архивариус выводит информацию о таблице
'в очень неудобном для работы формате
'Насколько удобнее, если свойства таблиц представить в виде БД
 
'Просто вставить код в новый модуль исследуемой БД
'и стартовать Sub GETTablesINFO
 
'Ким Владимир kim@intercare.ru, dr_kim@mail333.com
 
Private Sub GETTablesINFO()
'START ME!
'Получение INFO по таблицам базы
'Программа создаст
'- таблицу ~TBL со списком таблиц базы
' (кроме MSys*)с их основными свойствами
'- таблицу ~FLD со списком полей таблиц базы
'- таблицу ~PRP со списком свойств полей таблиц базы
'- связи между таблицами ~TBL,~FLD,~PRP
'Заполнив таблицы, откроет ~TBL
'таблицы ~FLD,~PRP будут открываться каскадно
Dim r1 As DAO.Recordset
Dim r2 As DAO.Recordset
Dim r3 As DAO.Recordset
 
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim prp As DAO.Property
Dim Id_Tbl As Long
Dim Id_fld As Long
Dim i As Long, ii As Long
 
DropTbl
CreateTBL1
CreateTBL2
CreateTBL3
CreateTBL4
 
Set r1 = CurrentDb.OpenRecordset("select * from [~tbl]")
Set r2 = CurrentDb.OpenRecordset("select * from [~fld]")
Set r3 = CurrentDb.OpenRecordset("select * from [~prp]")
 
On Error Resume Next
i = 0
ii = CurrentDb.TableDefs.Count
'цикл по таблицам кроме системных
For Each tdf In CurrentDb.TableDefs
i = i + 1
Debug.Print "TableDef (" & tdf.Name & ")" & i & " of " & ii & " Start:" & Time
    If Left(tdf.Name, 4) = "msys" Then GoTo nextTDF
    
   With r1
'пишем
    .AddNew
        ![Name] = tdf.Name
        ![Updatable] = tdf.Updatable
        ![DateCreated] = tdf.DateCreated
        ![LastUpdated] = tdf.LastUpdated
        ![Connect] = tdf.Connect
        ![Attributes] = tdf.Attributes
        ![SourceTableName] = tdf.SourceTableName
        ![RecordCount] = tdf.RecordCount
        ![ValidationRule] = tdf.ValidationRule
        ![ValidationText] = tdf.ValidationText
        ![ConflictTable] = tdf.ConflictTable
        ![ReplicaFilter] = Nz(tdf.ReplicaFilter, "")
        ![Orientation] = tdf.Properties("Orientation").Value
        ![OrderByOn] = tdf.Properties("OrderByOn").Value
        ![Description] = tdf.Properties("Description").Value
        ![Filter] = tdf.Properties("Filter").Value
        ![SubdatasheetName] = tdf.Properties("SubdatasheetName").Value
        ![LinkChildFields] = tdf.Properties("LinkChildFields").Value
        ![LinkMasterFields] = tdf.Properties("LinkMasterFields").Value
        ![SubdatasheetHeight] = tdf.Properties("SubdatasheetHeight").Value
        ![SubdatasheetExpanded] = tdf.Properties("SubdatasheetExpanded").Value
    .Update
    .MoveLast
       Id_Tbl = r1(0).Value
    End With
    
' цикл по полям таблицы
    For Each fld In tdf.Fields
       With r2
'пишем
        .AddNew
        ![IDTBL] = Id_Tbl
        ![NameField] = fld.Name
        .Update
        .MoveLast
       Id_fld = r2(0).Value
        End With
'цикл по свойствам поля таблицы
        For Each prp In fld.Properties
       With r3
'пишем
        .AddNew
        ![idFLD] = Id_fld
        ![PropertyName] = prp.Name
        ![PropertyValue] = prp.Value
        .Update
        End With
        Next prp
    
    Next fld
nextTDF:
Next tdf
 
Debug.Print "Finish: " & Time
Set r1 = Nothing
Set r2 = Nothing
Set r3 = Nothing
 
DoCmd.OpenTable "~tbl", acViewNormal, acReadOnly
 
End Sub
 
 
Private Sub DropTbl()
On Error Resume Next
CurrentDb.Execute "drop table [~prp]"
CurrentDb.Execute "drop table [~fld]"
CurrentDb.Execute "drop table [~tbl]"
End Sub
 
 
 
Private Sub CreateTBL1()
'создание таБлицы СПИСОК ТАБЛИЦ БАЗЫ И ИХ СВОЙСТВА
CurrentDb.Execute "CREATE TABLE [~TBL] ([idTBL] counter," & _
"[Name] text," & _
"[Updatable] logical," & _
"[DateCreated] date," & _
"[LastUpdated] date," & _
"[Connect] memo," & _
"[Attributes] memo," & _
"[SourceTableName] memo," & _
"[RecordCount] Long," & _
"[ValidationRule] memo," & _
"[ValidationText] memo," & _
"[ConflictTable] memo," & _
"[ReplicaFilter] memo," & _
"[Orientation] memo," & _
"[OrderByOn] memo," & _
"[Description] memo," & _
"[Filter] memo," & _
"[SubdatasheetName] memo," & _
"[LinkChildFields] memo," & _
"[LinkMasterFields] memo," & _
"[SubdatasheetHeight] Long," & _
"[SubdatasheetExpanded] memo," & _
"CONSTRAINT [id_Key] PRIMARY KEY ([idTBL]));"
End Sub
 
 
 
Private Sub CreateTBL2()
'создание таБлицы СПИСОК ПОЛЕЙ ТАБЛИЦ БАЗЫ
CurrentDb.Execute "CREATE TABLE [~FLD] ([idFLD] counter," & _
"[IDTBL] Long," & _
"[NameField] text," & _
"CONSTRAINT [id_Key] PRIMARY KEY ([idFLD]));"
End Sub
 
 
 
Private Sub CreateTBL3()
'создание таБлицы СПИСОК СВОЙСТВ ПОЛЕЙ ТАБЛИЦ БАЗЫ
CurrentDb.Execute "CREATE TABLE [~PRP] ([idPRP] counter," & _
"[idFLD] Long," & _
"[PropertyName] text," & _
"[PropertyValue] memo," & _
"CONSTRAINT [id_Key] PRIMARY KEY ([idPRP]));"
End Sub
 
 
Private Sub CreateTBL4()
'Устанавливаем связь между таблицами
   CurrentDb.Execute "ALTER TABLE [~fld] ADD CONSTRAINT [~ref1] " & _
"FOREIGN KEY (IDtbl) REFERENCES [~tbl] (idtbl)"
   CurrentDb.Execute "ALTER TABLE [~prp] ADD CONSTRAINT [~ref2] " & _
"FOREIGN KEY (IDfld) REFERENCES [~fld] (idfld)"
End Sub