MyTetra Share
Делитесь знаниями!
Время создания: 16.03.2019 23:43
Текстовые метки: GetObject
Раздел: Разные закладки - VBA - GetOpen
Запись: xintrea/mytetra_db_adgaver_new/master/base/1493352736bhlko0a2al/text.html на raw.githubusercontent.com

При нажатии на кнопку открывается экселовский файлик, только вот почему-то не просит обновить связи! Если открываю файл из-под винды - все нормально, но если через форму аксесса, открывается файлик и связи не обновляются и нет запроса на обновление.
Подскажите, пожалуйста, что не так???
Пробовал добавить: application.asktoupdatelinks = true, application.displayalerts = true - не помогло:(
Офис 2010-й...


Private Sub Кнопка3_Click()

Set obj = GetObject("путь к файлу xlsx")

obj.Application.Visible = True

obj.Parent.Windows(1).Visible = True

End Sub





Вот тебе рукотворный запрос на обновление. Запускается процедурой Links_Excel_Test

Public Sub Links_Excel_Test()
Dim objExcel As Object
Dim strCaption As String

On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
    If objExcel Is Nothing Then
        Err.Clear
        Set objExcel = CreateObject("Excel.Application")
            If objExcel Is Nothing Then Err.Clear: MsgBox "Не установлен MS Excel!", vbCritical, "Ошибка": Exit Sub
    End If
    With objExcel
        .Visible = True
        .DisplayAlerts = False
        .ActivateMicrosoftApp 4& 'xlMicrosoftAccess = 4
            With .Workbooks
                .Open "путь к файлу xls", 0
                    If MsgBox("Обновить ссылки?", vbQuestion Or vbYesNo) = vbYes Then Excel_UpdateLinks .Item(.Count)
            End With
    End With

Set objExcel = Nothing
End Sub

Private Sub Excel_UpdateLinks(objWorkbook As Object)
Dim arrLinks As Variant
Dim i As Long, lngRetVal As Long
Dim strFileName As String
Dim dlgOpenFile As Object 'FileDialog

arrLinks = objWorkbook.LinkSources(1&) 'xlExcelLinks=1
    If Not IsEmpty(arrLinks) Then
        If IsArray(arrLinks) Then
            For i = 1 To UBound(arrLinks)
                If Len(Dir$(arrLinks(i))) = 0 Then
                    lngRetVal = MsgBox("Не нашли файл по ссылке " & """" & arrLinks(i) & """" & vbNewLine & _
                                       "Искать бум?", vbCritical Or vbYesNo, "Обновление ссылок")
                        If lngRetVal = vbYes Then
                            strFileName = arrLinks(i)
                                If Len(Dir$(strFileName)) = 0 Then
                                    Do While Len(Dir$(strFileName, vbDirectory)) = 0
                                        strFileName = Left$(strFileName, InStrRev(strFileName, "\") - 1)
                                            If InStr(1, strFileName, "\") = 0 Then strFileName = CurDir: Exit Do
                                    Loop
                                End If
                            Set dlgOpenFile = Application.FileDialog(1&) 'msoFileDialogOpen
                                With dlgOpenFile
                                    .InitialFileName = strFileName
                                    .AllowMultiSelect = False
                                    .Title = "Укажите файл для восстановления ссылки"
                                        If .Show = -1 Then
                                            objWorkbook.ChangeLink arrLinks(i), .SelectedItems(1), 1& 'xlExcelLinks
                                        Else
                                            MsgBox "Не указано новое положение файла для восстановления ссылки!" & vbNewLine & _
                                                    "Ссылка не будет восстановлена.", vbInformation
                                        End If
                                End With
                            strFileName = ""
                        End If
                End If
            Next i
        End If
    End If
    If IsArray(arrLinks) Then Erase arrLinks
Set dlgOpenFile = Nothing
Set objWorkbook = Nothing
End Sub


Да, кстати, тут не параметр True, а вполне себе константы - 0, 1, 2, 3. Смотри в хелпе...

obj.Workbooks.Open "Путь к файлу", True



Вот это заремь

.ActivateMicrosoftApp 4& 'xlMicrosoftAccess = 4


И тут ещё поправь

...
                Next i
            objWorkbook.UpdateLink objWorkbook.LinkSources
            Erase arrLinks
        End If 
    End If
    'If IsArray(arrLinks) Then Erase arrLinks'а это убери
...






- Код

Private Sub Кнопка0_Click()
Dim objExcel As Object
Dim objWorkbook As Object
Dim strFileName As String

On Error Resume Next
strFileName =  "D:\List.xlsx"'тут уж придумай сам откуда брать путь
    If Len(Dir$(strFileName)) = 0 Then MsgBox "Нет Файла!": Exit Sub
Set objExcel = GetObject(, "Excel.Application") 'получаем объект, если он открыт (Excel запущен уже)
    If objExcel Is Nothing Then 'не получили (не запущен)
        Err.Clear 'очищаем от ошибки
        Set objExcel = CreateObject("Excel.Application") 'создаём объект (запускаем Excel)
            If objExcel Is Nothing Then Err.Clear: MsgBox "Не установлен MS Excel!", vbCritical, "Ошибка": Exit Sub 'без комментариев
    End If
    With objExcel
        .DisplayAlerts = False
'        .ActivateMicrosoftApp 4& 'xlMicrosoftAccess = 4'это, если нужно переключиться на окно Access
        Set objWorkbook = .Workbooks.Item(Mid(strFileName, InStrRev(strFileName, "\") + 1)).Windows(1)
            If objWorkbook Is Nothing Then 'не получили, книга не открыта
                Err.Clear 'очищаем от ошибки
                Set objWorkbook = .Workbooks.Open(strFileName, 0) '0 - ссылки не обновляем при открытии
                objWorkbook.UpdateLink objWorkbook.LinkSources
                    If Err.Number = 1004 Then 'не нашли файлы для обновления ссылок
                        Err.Clear 'очищаем от ошибки
                            If MsgBox("Обновить ссылки?", vbQuestion Or vbYesNo) = vbYes Then
                                Excel_UpdateLinks objWorkbook
                            Else
                                MsgBox "Внимание!" & vbNewLine & "Ссылки в книге """ & _
                                    Mid(strFileName, InStrRev(strFileName, "\") + 1) & """ не обновлены!", vbInformation, "Обновление ссылок"
                            End If
                    ElseIf Err Then
                        MsgBox "Ошибка: " & Err.Number & vbNewLine & Err.Description, vbCritical, "Обновление ссылок"
                        Err.Clear 'очищаем от ошибки
                        Exit Sub 'Вообще надо посмотреть, что за ошибка, попробовать обработать...
                    End If
                With objWorkbook
                    .Visible = True
                    .Activate
                End With
            End If
        .Visible = True
            If Not .UserControl Then .UserControl = True
            If .Windows.Count > 0 Then .Windows(.Windows.Count).Activate
        Call SetForegroundWindow(.hWnd) 'это, если нужно лицезреть Excel
    End With
Set objWorkbook = Nothing
Set objExcel = Nothing
End Sub

Private Function Excel_UpdateLinks(objWorkbook As Object) As Boolean
Dim arrLinks As Variant
Dim i As Long, lngRetVal As Long
Dim strFileName As String
Dim dlgOpenFile As Object 'FileDialog

arrLinks = objWorkbook.LinkSources(1&) 'xlExcelLinks=1
    If Not IsEmpty(arrLinks) Then
        If IsArray(arrLinks) Then
                For i = 1 To UBound(arrLinks)
                    If Len(Dir$(arrLinks(i))) = 0 Then
                        lngRetVal = MsgBox("Не нашли файл по ссылке " & """" & arrLinks(i) & """" & vbNewLine & _
                                           "Искать бум?", vbQuestion Or vbYesNo, "Обновление ссылок")
                            If lngRetVal = vbYes Then
                                strFileName = arrLinks(i) 'получаем ссылку (путь) на файл
                                    If Len(Dir$(strFileName)) = 0 Then 'проверяем на существование (если нет файла, то идём к циклу)
                                        Do While Len(Dir$(strFileName, vbDirectory)) = 0 'ищем путь (папку)
                                            strFileName = Left$(strFileName, InStrRev(strFileName, "\") - 1)
                                                If InStr(1, strFileName, "\") = 0 Then strFileName = CurDir: Exit Do 'если не нашли папку, получим текущий каталог
                                        Loop
                                    End If
                                Set dlgOpenFile = Application.FileDialog(3&) 'msoFileDialogFilePicker
                                    With dlgOpenFile
                                        .InitialFileName = strFileName
                                        .AllowMultiSelect = False
                                        .Title = "Укажите файл для восстановления ссылки"
                                            If .Show = -1 Then
                                                objWorkbook.ChangeLink arrLinks(i), .SelectedItems(1), 1& 'xlExcelLinks
                                            Else
                                                MsgBox "Не указано новое положение файла для восстановления ссылки!" & vbNewLine & _
                                                        "Ссылки не будут обновлены.", vbInformation, "Обновление ссылок"
                                                Erase arrLinks
                                                Exit Function
                                            End If
                                    End With
                                strFileName = ""
                            Else
                                MsgBox "Не указано новое положение файла для восстановления ссылки!" & vbNewLine & _
                                        "Ссылки не будут обновлены.", vbInformation, "Обновление ссылок"
                                Erase arrLinks
                                Exit Function
                            End If
                    End If
                Next i
            objWorkbook.UpdateLink objWorkbook.LinkSources 'обновим ссылки в книге
            Erase arrLinks
        End If
    End If
Excel_UpdateLinks = True
Set dlgOpenFile = Nothing
End Function
Так же в этом разделе:
 
MyTetra Share v.0.65
Яндекс индекс цитирования