Макрос. Черно-белая печать и сохранение только значений листа

@asd192 · Регистрация: 05.06.2012

Студворк — интернет-сервис помощи студентам

Книга. Много листов. Листы с разноцветными ячейками. Нужно:
1. При нажатии на кнопку 1, оправить только 1-ый лист на печать с параметром "черно-белая" печать.
2. При нажатии на кнопку 2, открыть окно с предложением о сохранении первого(только первого) листа этой книги c именем файла из ячейки(доустим F4). После того как пользователь выберет куда сохранить и сохранит файл. Он(файл) должен содержать в себе - только первый лист нашей книги... без формул, макросов и различных элементов(т.е. содержать в себе только значения ячеек с сохранением форматирования(ширина столбцов, шрифты и пр.). Иметь, по умолчанию, параметр "черно-белая" печать. И, не очень важно, но желательно, чтобы был защищен паролем от любых изменений, кроме печати.

Т.е. я поработал с книгой, нажал кнопку сохранения. Книга создала в памяти копию себя. Удалила в себе все листы кроме первого. Очистилась от формул, макросов и пр.. Поставила себе параметр "черно-белая" печать. Открыла мне окно с предложением сохранить файл под именем из ячейки F4. Я выбрал путь сохранения и сохранил файл. Кастрированная книга уведомила меня, что сохранилась успешно и закрылась. Изначальная книга осталась без изменений(открытая и покорно ждущая дальнейших манипуляций). А кастрированная после последующих открытий не давала ничего изменять(находясь под действием пароля) и разрешала только печатать себя.

Если не слишком губу раскатал... то пусть код макроса будет содержать пояснения. И в идеале - чтобы, после сохранения, файл еще и в зип архив себя запаковал под тем же именем из ячейки F4.

В файле - шаблон.

@asd192 · 01.07.2012, 12:17 **[ТС]**

С первым вроде разобрался.

Visual Basic
1
2
3
4
5
6
7
8
9
Sub Макрос3()
    Application.PrintCommunication = False
       With ActiveSheet.PageSetup
        .BlackAndWhite = True
       End With
    Application.PrintCommunication = True
 ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _
        :=True, IgnorePrintAreas:=False
End Sub

@asd192 · 01.07.2012, 20:23 **[ТС]**

Второе.

Нашел как сохранить первый лист очистив его от всего - сохранить в PDF

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Очистить лист()
    Sheets("Лист1").Copy
    Cells.Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
         
    Selection.Copy
    Application.CutCopyMode = False
   
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\asd192\Desktop\" & Range("F4") & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, _
        OpenAfterPublish:=False
    ActiveWindow.Close
End Sub

Нашел как заархивировать в ZIP-архив.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sub CreateBackup()
     ' Ìàêðîñ ñîçäàíèÿ ðåçåðâíîé êîïèè òåêóùåãî ôàéëà
    ' ×òîáû ìàêðîñ îáðàáàòûâàë àêòèâíóþ êíèãó - çàìåíèòå â êîäå
    ' âñå ThisWorkbook íà ActiveWorkbook
    ' Àðõèâàöèÿ ôàéëà îñóùåñòâëÿåòñÿ ñðåäñòâàìè Windows
    
     Const PROJECT_NAME = "Ïðîòîêîëû" ' íàçâàíèå âàøåé ïðîãðàììû (ëþáîé òåêñò)
    On Error Resume Next: ThisWorkbook.Save ' ñîõðàíÿåì êíèãó Excel
    
     ' ôîðìèðóåì ïóòü ê ïàïêå, êóäà áóäåò ïîìîùåíà êîïèÿ ôàéëà (â âèäå àðõèâà)
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
     MkDir BackupsPath ' ñîçäà¸ì ïàïêó, åñëè òàêîâîé åù¸ íåò
    
     ext$ = Split(ThisWorkbook.Name, ".")(UBound(Split(ThisWorkbook.Name, "."))) ' ðàñøèðåíèå ôàéëà
    ' ôîðìèðóåì ïóòü äëÿ êîïèè ôàéëà Excel
    FileNameXls = BackupsPath & " " & [F4] & " " & Format(Now, "DD-MM-YYYY__HH-NN-SS") & "." & ext$
     ' ôîðìèðóåì ïóòü äëÿ ñîçäàâàåìîãî àðõèâà ZIP
    FileNameZip = BackupsPath & " " & [F4] & " " & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".zip"
     
     ThisWorkbook.SaveCopyAs FileNameXls ' ñîçäà¸ì êîïèþ êíèãè
    ZIPresult = Zip_File(FileNameXls, FileNameZip, True) ' óïàêîâûâàåì êîïèþ êíèãè â àðõèâ ZIP
    
     Debug.Print "Ðåçóëüòàò àðõèâàöèè: " & IIf(ZIPresult, "âûïîëíåíà óñïåøíî", "îøèáêà")
     Debug.Print "Ñîçäàí àðõèâ: " & Dir(FileNameZip)
End Sub
 
 
Function Zip_File(ByVal FileNameXls, ByVal FileNameZip, _
                   Optional ByVal DeleteSourceFile As Boolean = False) As Boolean
     ' Ôóíêöèÿ îñóùåñòâëÿåò óïàêîâêó ôàéëà FileNameXls â àðõèâ ñ èìåíåì FileNameZip
    ' åñëè DeleteSourceFile = TRUE, èñõîäíûé ôàéë FileNameXls óäàëÿåòñÿ ïî îêîí÷àíèè àðõèâàöèè
    ' Âîçâðàùàåò TRUE, åñëè àðõèâàöèÿ çàâåðøèëîñü óäà÷íî, è FALSE â ïðîòèâíîì ñëó÷àå
    On Error Resume Next: Err.Clear:
     If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip
     If Len(Dir(FileNameXls)) = 0 Then MsgBox "Ôàéë """ & FileNameXls & """ íå íàéäåí!", _
        vbCritical, "Îøèáêà â ôóíêöèè Zip_File": Exit Function
 
     Open FileNameZip For Output As #1
     Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
     Close #1
     Set oApp = CreateObject("Shell.Application")
     oApp.Namespace(FileNameZip).CopyHere FileNameXls    'êîïèðóåì ôàéë â ñæàòóþ ïàïêó
 
     Do Until oApp.Namespace(FileNameZip).Items.Count = 1    'æä¸ì çàâåðøåíèÿ óïàêîâêè ôàéëà
        Application.Wait (Now + TimeValue("0:00:01"))
     Loop
 
 
 
     If DeleteSourceFile Then Kill FileNameXls    ' óäàëÿåì âðåìåííî ñîçäàííûé ôàéë
    Zip_File = Err = 0    ' âîçâðàùàåì ðåçóëüòàò óïàêîâêè (TRUE, åñëè âñ¸ çàâåðøèëîñü óäà÷íî)
End Function

Не могу понять - как соеденить это? Чтобы архивировался PDF.

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Реализация движения на Box2D v3 - трение и коллизии с повёрнутыми стенами 8Observer8 20.02.2026 Содержание блога Box2D позволяет легко создать главного героя, который не проходит сквозь стены и перемещается с заданным трением о препятствия, которые можно располагать под углом, как верхнее. . .	Конвертировать закладки radiotray-ng в m3u-плейлист damix 19.02.2026 Это можно сделать скриптом для PowerShell. Использование . \СonvertRadiotrayToM3U. ps1 <path_to_bookmarks. json> Рядом с файлом bookmarks. json появится файл bookmarks. m3u с результатом. # Check if. . .	Семь CDC на одном интерфейсе: 5 U[S]ARTов, 1 CAN и 1 SSI Eddy_Em 18.02.2026 Постепенно допиливаю свою "многоинтерфейсную плату". Выглядит вот так: https:/ / www. cyberforum. ru/ blog_attachment. php?attachmentid=11617&stc=1&d=1771445347 Основана на STM32F303RBT6. На борту пять. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .
И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»	SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .