Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
29.03.2024, 03:29:22

Войти
Хотите поблагодарить участника за дельный совет? Нажмите [Повысить]. Так вы заслуженно поднимите репутацию активному участнику.
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Копировать фоновую картинку (подложку) с одного листа на другой
Страниц: [1]   Вниз
Печать
Автор Тема: Копировать фоновую картинку (подложку) с одного листа на другой  (Прочитано 3403 раз)
0 Пользователей и 1 Гость смотрят эту тему.
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« : 11.07.2019, 18:38:15 »

Здравствуйте.
Покопала в справочниках и нашли, что фоновую картинку на лист средствами VBA можно только задать - инструкцией
Код: (vb)
ActiveSheet.SetBackgroundPicture Filename:= "Path/Filename.jpg"

Хотелось бы ту же картинку установить и на другой лист программно : для макроса, который воссоздает все элементы существующего объемного файла Excel в новый файл с нуля. Возможно, через экспорт/импорт этой фоновой картинки.. Кто знает, как к ней обратиться из VBA ?
Записан
boa
Старожил
****

Репутация: +22/-0
Офлайн Офлайн

Сообщений: 252


Доброта спасет мир...


Просмотр профиля WWW
« Ответ #1 : 12.07.2019, 13:29:02 »

Не все так просто, но возможно.
Надо немножко "разобрать" файл и найти картинку
Код: (vb)
Sub test()
    Dim oSourseSheet As Worksheet: Set oSourseSheet = Application.ActiveSheet
    Dim WB As Workbook: Set WB = Workbooks.Add(xlWBATWorksheet)
    
    If CopyBackgroundPicture(oSourseSheet, WB.Sheets(1)) _
        Then MsgBox "Подложка скопирована": WB.Activate _
        Else MsgBox "Что-то пошло не так"
End Sub

Private Function CopyBackgroundPicture(ByRef oSourseSheet As Worksheet, ByRef oTargetSheet As Worksheet) As Boolean
'' Author:  boa
'' Written: 12.07.2019
'' Edited:
'  Description: Копирует подложку листа SourseSheet
'               TargetSheet - лист куда надо скопировать

    On Error Resume Next
    Dim newFile$, sFiles$
    Dim ZipFile$, PathZip$
    Dim Pict$, PathPicture$
    
    newFile = Environ("temp") & "\temp.xlsx"
    ZipFile = Environ("temp") & "\temp.zip"
    If Dir(ZipFile) <> "" Then Kill ZipFile
    
    CopySheet oSourseSheet, newFile
    Name newFile As ZipFile
    PathZip = UnZipFiles(ZipFile)
    
    ' имя файла "image1.png" получено экспериментальным путем. Может отличаться. Надо тестить.
    ' можно перебором вытянуть все картинки и потом предоставить пользователю право выбора.
    oTargetSheet.SetBackgroundPicture Filename:=PathZip & "xl\media\" & "image1.png"
    
    Shell "cmd /c rd /S/Q """ & PathZip & """"  'удаляем временную папку Zip
    Kill ZipFile                                'удаляем файл Zip
    
    CopyBackgroundPicture = Err = 0
End Function

Private Sub CopySheet(ByVal oSourseSheet As Worksheet, ByVal sSaveFullName$)
    Dim WB As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set WB = Workbooks.Add(xlWBATWorksheet)
    With WB
        oSourseSheet.Copy after:=.Sheets(1)
        .Sheets(1).Delete
        .SaveAs sSaveFullName
        .Close False
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Private Function UnZipFiles$(ByVal ZipName$)
' ZipName - полный путь к архиву
' DestPath - полный путь к папке для распаковки архива

Dim ShellApp As Object, DestPath As String
    DestPath = Environ("tmp") & "\UNZIP_" & CLng(Timer) & "\"
    MkDir DestPath
    Set ShellApp = CreateObject("Shell.Application")
    'Copy the files in the newly created folder
    ShellApp.Namespace((DestPath)).CopyHere ShellApp.Namespace((ZipName)).Items
    Set ShellApp = Nothing
    UnZipFiles = DestPath
End Function

« Последнее редактирование: 12.07.2019, 13:34:43 от boa » Записан

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #2 : 12.07.2019, 17:19:09 »

Спасибо.
У меня выходит ошибка компиляции "Неверные аргумент или вызов процедуры"  на строке
Код: (vb)
Private Function CopyBackgroundPicture(ByRef oSourseSheet As Worksheet, ByRef oTargetSheet As Worksheet) As Boolean
.
Записан
boa
Старожил
****

Репутация: +22/-0
Офлайн Офлайн

Сообщений: 252


Доброта спасет мир...


Просмотр профиля WWW
« Ответ #3 : 12.07.2019, 22:55:59 »

Скачал файл из предыдущего поста, нажал кнопку, все отработало.
может у Вас какие-то специфические настройки...?
попробуйте подкорректировать строку
    If CopyBackgroundPicture(oSourseSheet, WB.Sheets(1)) = True _
может, поможет...
 В замешательстве
Записан

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #4 : 17.07.2019, 19:57:15 »

Ваша программа работает отлично.
Спасибо большое.
Записан
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #5 : 18.07.2019, 10:46:33 »

Почему-то, через какое-то время, программа выдает ошибку "не удалось найти файл [+ имя temp.file]".
Если загружаю Ваш файл из сообщения "Ответ #1", снова работает исправно. И так уже раз восемь.
Найти причину, почем начинает сбоить, мне пока не удалось.
Записан
boa
Старожил
****

Репутация: +22/-0
Офлайн Офлайн

Сообщений: 252


Доброта спасет мир...


Просмотр профиля WWW
« Ответ #6 : 22.07.2019, 08:29:39 »

программа выдает ошибку "не удалось найти файл [+ имя temp.file]".
Попробуйте переписать строку
Код: (vb)
        .SaveAs sSaveFullName 
на
Код: (vb)
        .SaveAs Filename:=sSaveFullName, FileFormat:=xlWorkbookDefault 
может поможет.
Надо смотреть при пошаговой отладке (F8) на какой строке произошел сбой.
Может вы пытаетесь из несохраненного файла вытянуть подложку...
Может еще что-то...
Записан

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru