При выполнении макроса, (который по крупинкам собирался с различных форумов) выполняющего вызов окна на выбор папки, в которой во всех файлах разрываются связи с другими книгами. Макрос запускается из кнопки на ленте (Офис 2007). Когда-то все работало:( А сейчас возникает ошибка: erorr 1004 method 'breaklink' of object '_Workbook' failed. Ругается на ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks Помогите, пожалуйста, разобраться по какой причине возникает ошибка и поделиться способами решения. Собственно сам код:
[vba]
Код
Sub Links(ByVal Control As IRibbonControl)
'открываем всё подряд DisplayAlerts = False Dim aFile As File, fso As New FileSystemObject, wkb As Workbook ПутьКПапке = GetFolderPath("Заголовок окна", ThisWorkbook.Path) ' запрашиваем имя папки If ПутьКПапке = "" Then Exit Sub ' выход, если пользователь отказался от выбора папки For Each aFile In fso.getfolder(ПутьКПапке).Files DisplayAlerts = False If fso.GetExtensionName(aFile.Name) Like "xls*" Then Set wkb = Workbooks.Open(aFile.Path) 'обрезаем связи
Dim iLinks As Variant, i& iLinks = ActiveWorkbook.LinkSources(xlExcelLinks) If Not IsEmpty(iLinks) Then Set fso = New FileSystemObject For i = 1 To UBound(iLinks) ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks Next i End If
'сохраняем и переходим к следующему
wkb.Close SaveChanges:=True Set wkb = Nothing End If Next
'заканчиваем
End Sub
[/vba]
Функция на вызов окна, которую я использую (не моя), мало ли:
[vba]
Код
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _ Optional ByVal InitialPath As String = "W:\Журавлёва\") As String ' функция выводит диалоговое окно выбора папки с заголовком Title, ' начиная обзор диска с папки InitialPath ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора Dim PS As String: PS = Application.PathSeparator With Application.FileDialog(msoFileDialogFolderPicker) If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath If .Show <> -1 Then Exit Function GetFolderPath = .SelectedItems(1) If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS End With End Function
[/vba]
Также интересует, как убрать всплывающий запрос Excel на неудачную попытку обновления связей. UpdateLinks и DisplayAlerts не помогают. Помогите, пожалуйста, дилетанту.
Всем здравствуйте.
При выполнении макроса, (который по крупинкам собирался с различных форумов) выполняющего вызов окна на выбор папки, в которой во всех файлах разрываются связи с другими книгами. Макрос запускается из кнопки на ленте (Офис 2007). Когда-то все работало:( А сейчас возникает ошибка: erorr 1004 method 'breaklink' of object '_Workbook' failed. Ругается на ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks Помогите, пожалуйста, разобраться по какой причине возникает ошибка и поделиться способами решения. Собственно сам код:
[vba]
Код
Sub Links(ByVal Control As IRibbonControl)
'открываем всё подряд DisplayAlerts = False Dim aFile As File, fso As New FileSystemObject, wkb As Workbook ПутьКПапке = GetFolderPath("Заголовок окна", ThisWorkbook.Path) ' запрашиваем имя папки If ПутьКПапке = "" Then Exit Sub ' выход, если пользователь отказался от выбора папки For Each aFile In fso.getfolder(ПутьКПапке).Files DisplayAlerts = False If fso.GetExtensionName(aFile.Name) Like "xls*" Then Set wkb = Workbooks.Open(aFile.Path) 'обрезаем связи
Dim iLinks As Variant, i& iLinks = ActiveWorkbook.LinkSources(xlExcelLinks) If Not IsEmpty(iLinks) Then Set fso = New FileSystemObject For i = 1 To UBound(iLinks) ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks Next i End If
'сохраняем и переходим к следующему
wkb.Close SaveChanges:=True Set wkb = Nothing End If Next
'заканчиваем
End Sub
[/vba]
Функция на вызов окна, которую я использую (не моя), мало ли:
[vba]
Код
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _ Optional ByVal InitialPath As String = "W:\Журавлёва\") As String ' функция выводит диалоговое окно выбора папки с заголовком Title, ' начиная обзор диска с папки InitialPath ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора Dim PS As String: PS = Application.PathSeparator With Application.FileDialog(msoFileDialogFolderPicker) If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath If .Show <> -1 Then Exit Function GetFolderPath = .SelectedItems(1) If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS End With End Function
[/vba]
Также интересует, как убрать всплывающий запрос Excel на неудачную попытку обновления связей. UpdateLinks и DisplayAlerts не помогают. Помогите, пожалуйста, дилетанту.Литраж
Сообщение отредактировал Литраж - Пятница, 11.04.2014, 10:25