Sub Таймер_Обновления()

On Error Resume Next

tt = Timer

With ThisWorkbook

For Each con In .Connections

t = Timer

con.Refresh

t = Timer - t: Debug.Print Round(t, 2) & " " & con

Next con

End With

tt = Timer - tt: Debug.Print Round(tt, 2) & "==="

'ThisWorkbook.Connections("04_IncGretQuick_NonStr").Refresh

End Sub

'=======================================================================================

Sub Параметры_кнопки()

Dim oSh As Shape

For Each oSh In ActiveSheet.Shapes

' : AlternativeText : "main" : String

' : OnAction : "'Name6.xlsm'!MainSelect" : String

Debug.Print oSh.AlternativeText & " - " & oSh.OnAction

Next

End Sub

Sub Параметры_кнопки()

Dim oSh As Shape

For Each oSh In ActiveSheet.Shapes

' : AlternativeText : "main" : String

' : OnAction : "'Name.xlsm'!MainSelect" : String

Debug.Print oSh.AlternativeText & " - " & oSh.OnAction

Next

End Sub

'=======================================================================================

Sub RefAllCon()

Dim i As Long ': i = 1

Dim t As Variant, tt As Variant

Dim oCon As WorkbookConnection, strConName As String

Dim rCell As Range

Dim oSh As Worksheet

Dim oWb As Workbook

Dim strShRefName As String: strShRefName = "ListRef" 'лист с параметрами обновлений

Dim iNbRowStart As Long: iNbRowStart = 2

Dim iNbClnStart As Long: iNbClnStart = 1

On Error Resume Next

tt = Timer

EventsChange False

With ThisWorkbook

With .Sheets(strShRefName) 'очистка листа

iNbClnEnd = .Cells(iNbRowStart - 1, 256).End(xlToLeft).Column

iNbRowEnd = .Columns(iNbClnStart).Rows(65536).End(xlUp).Row

If iNbRowEnd <= 1 Then iNbRowEnd = 10 'на всякий случай

Range(.Cells(iNbRowStart, iNbClnStart), .Cells(iNbRowEnd, iNbClnEnd)).ClearContents

For Each oCon In ThisWorkbook.Connections

strConName = oCon.Name

Application.StatusBar = "Обновление " & oCon

t = Timer

' If strConName = "FAF" Then Stop

обновление = FnRefCon(oCon)

t = Timer - t: Debug.Print Round(t, 2) & " " & oCon

Путь_к_источнику = FnPathFileSource(oCon)

.Cells(iNbRowStart + i, iNbClnStart).value = Round(t, 2) 'Скорость обновления

.Cells(iNbRowStart + i, iNbClnStart + 1).value = oCon ' имя обновления

.Cells(iNbRowStart + i, iNbClnStart + 2).value = Format(FnTimeRefCon(oCon), "DD.MM.YYYY HH:mm:ss") 'Время обновления

.Cells(iNbRowStart + i, iNbClnStart + 3).value = FileDateTime(Путь_к_источнику) 'Время изменения файла источеика

Гиперссылка = m_Ref.FnHyperlinks(.Cells(iNbRowStart + i, iNbClnStart + 4), Путь_к_источнику, Путь_к_источнику) 'гиперссылка на источник

Путь_к_источнику = ""

Application.StatusBar = False

i = i + 1

DoEvents

Next 'oCon

tt = Timer - tt:: Debug.Print Round(tt, 2) & "==="

'итоги

.Cells(iNbRowStart + i, iNbClnStart + 1).value = "==="

.Cells(iNbRowStart + i, iNbClnStart).value = Round(tt, 2)

End With

End With

EventsChange True

'ThisWorkbook.Connections("04_IncGretQuick_NonStr").Refresh

End Sub

'=======================================================================================

'=======================================================================================

'время последнего обновления

'

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnTimeRefCon(oCon) As Date

Dim vType As XlConnectionType

vType = oCon.Type

With oCon

If vType = xlConnectionTypeODBC Then FnTimeRefCon = .ODBCConnection.RefreshDate

If vType = xlConnectionTypeOLEDB Then FnTimeRefCon = .OLEDBConnection.RefreshDate

End With

' FnTimeRefCon = dDateRef

End Function

'=======================================================================================

'=======================================================================================

'путь к файлу источнику подключения

'

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnPathFileSource(ByVal oCon As WorkbookConnection) As String

Dim strPathFileSource As String

Dim vType As XlConnectionType

Dim m As Variant, iNbItem As Integer 'элемент в массиве для определениия источника

vType = oCon.Type

With oCon

If vType = xlConnectionTypeODBC Then strPathFileSource = .ODBCConnection.Connection: iNbItem = 1

If vType = xlConnectionTypeOLEDB Then strPathFileSource = .OLEDBConnection.Connection: iNbItem = 4

End With

'Путь к файлу

'DBQ=

m = Split(strPathFileSource, "DBQ=", -1, vbTextCompare)

m = Split(m(UBound(m)), "=", -1, vbTextCompare)

strPathFileSource = m(LBound(m))

strPathFileSource = Replace(strPathFileSource, ";DefaultDir", "", 1, -1, vbTextCompare)

FnPathFileSource = strPathFileSource

End Function

''=======================================================================================

''время последнего изменения файла источника подключения

''

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Function FnRefConDateFileSource(ByVal oCon As WorkbookConnection) As Date

' Dim strPathFileSource As String

' Dim m As Variant, iNbItem As Integer 'элемент в массиве для определениия источника

' Dim vType As XlConnectionType: vType = oCon.Type

'

' With oCon

' If vType = xlConnectionTypeODBC Then strPathFileSource = .ODBCConnection.Connection: iNbItem = 1

' If vType = xlConnectionTypeOLEDB Then strPathFileSource = .OLEDBConnection.Connection: iNbItem = 4

' End With 'oCon

' 'Путь к файлу

' m = Split(strPathFileSource, "=", -1, vbTextCompare)

'

' strPathFileSource = m(LBound(m) + iNbItem)

' strPathFileSource = Replace(strPathFileSource, ";DefaultDir", "", 1, -1, vbTextCompare)

'

' FnRefConDateFileSource = Format(FileDateTime(strPathFileSource), "DD.MM.YYYY hh:mm:ss")

' ';DefaultDir

' Set oCon = Nothing

'End Function

''=======================================================================================

'=======================================================================================

'Обновление подключения с запросом (время последнего обновления

'

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnRefCon(ByVal oCon As WorkbookConnection) As Boolean

Application.StatusBar = "Обновление " & strConName

Dim dDateRef As Date

Dim dDateDelta As Date

Dim vType As XlConnectionType

vType = oCon.Type

With oCon

If vType = xlConnectionTypeODBC Then dDateRef = .ODBCConnection.RefreshDate

If vType = xlConnectionTypeOLEDB Then dDateRef = .OLEDBConnection.RefreshDate

dDateDelta = Now - dDateRef

If dDateDelta < "01:00:00" Then

Select Case MsgBox("Последнее обновление было " & dDateDelta & " назад." & _

vbCrLf & "Обновить " & strConName, 52, "Обновление " & strConName)

Case 6 ' Да

.Refresh: FnRefCon = True

Case 7 ' Нет

FnRefCon = True

End Select

Else

.Refresh: FnRefCon = True

End If

End With

Application.StatusBar = False

End Function

'=======================================================================================

'=======================================================================================

'Вставка гиперссылки

'

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnHyperlinks(ByVal rCell As Range, _

ByVal strLink As String, _

ByVal strLinkName As String) As Boolean

'Sub FnHyperlinks(ByVal rCell As Range)

Dim strShName As String

Dim oSh As Worksheet

'Dim oWb As Workbook

strShName = rCell.Worksheet.Name

Set oSh = rCell.Worksheet

' Set oWb = oSh.Parent

oSh.Hyperlinks.Add Anchor:=rCell, Address:= _

strLink, TextToDisplay:=strLinkName

Set oSh = Nothing

' Set oWb = Nothing

FnHyperlinks = True

End Function

'=======================================================================================

''=======================================================================================

'Sub Ref_SSAR()

' Обновить = FnRefCon("07_SSAR(Suivi)")

' Обновить = FnRefCon("07_SSAR(TCM)")

'End Sub

'

'

''07_SSAR(Suivi)

''=======================================================================================

'Sub Ref_TOP()

' Обновить = FnRefCon("01_Prod")

' Обновить = FnRefCon("04_IncGret")

' Обновить = FnRefCon("02_SAVES")

' Обновить = FnRefCon("03_CSC")

' Обновить = FnRefCon("03_TCP")

' Обновить = FnRefCon("03_TCP_PJI")

'

'End Sub

'

'

''=======================================================================================

'Sub Ref_CSC_TCP()

' Обновить = FnRefCon("03_CSC")

' Обновить = FnRefCon("03_TCP")

' Обновить = FnRefCon("03_TCP_PJI")

' Обновить = FnRefCon("01_Prod")

'End Sub

'

'

''=======================================================================================

'Sub Ref_CSC()

' Обновить = FnRefCon("01_Prod")

' Обновить = FnRefCon("03_CSC")

'End Sub

'

''=======================================================================================

'Sub Ref_IncGret()

' Обновить = FnRefCon("01_Prod")

' Обновить = FnRefCon("04_IncGret")

'End Sub

'

''=======================================================================================

'Sub Ref_IncGret15PJI()

' Обновить = FnRefCon("04_IncGret_15PJI(P)")

' Обновить = FnRefCon("01_Prod")

' Обновить = FnRefCon("04_IncGret")

'End Sub

'

''=======================================================================================

'Sub Ref_SAVES()

' Обновить = FnRefCon("02_SAVES")

'End Sub

'

''=======================================================================================

'Sub Ref_CDU()

' Обновить = FnRefCon("11_CDU.v.2")

' Обновить = FnRefCon("01_Prod")

'End Sub

'

''=======================================================================================

'Sub Ref_NonStr()

' Обновить = FnRefCon("01_Prod")

' Обновить = FnRefCon("04_IncGret_NonStr(%)")

'End Sub

'

''=======================================================================================

'Sub Ref_PAD()

' Обновить = FnRefCon("01_Prod")

' Обновить = FnRefCon("04_IncGretQuick_PAD_RE2")

' Обновить = FnRefCon("04_IncGretQuick_PAD_RS2")

'End Sub

'

'