Страницы: 1
RSS
Сохранение печатающихся листов в папку при помощи макроса, Как добавить еще строчки кода для того что бы макрос не только выполнянл печать паспортом поочередную, но и еще сохранял в отдельную папку в pdf
 
 Добрый день !
Имеется макрос печатающий паспорта, в нем указывается количество и серийные номера, после того как вводится количество, макрос выводит окно с просьбой ввести серийный номер, и это окно открывается столько раз сколько было указано и паспорта печатаются друг за другом.

Вот фрагмент кода который отвечает за отправку на принтер
Application.PrintOut FileName:="", Range:=wdPrintRangeOfPages, Item:= _
   wdPrintDocumentWithMarkup, Copies:=1, Pages:="4,1,2,3", PageType:= _
   wdPrintAllPages, Collate:=True, Background:=False, PrintToFile:=False, _
   PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
   PrintZoomPaperHeight:=0  'вывод на печать

Не могу понять как сюда внедрить что бы он еще и сохранял это файл в пдф, подскажите пожалуйста что можно сделать
 
Anri_amar, Доброго дня, я бы вам рекомендовал, показать или пример(файл с обезличеными данными) или привести код полностью а не огрызок.

P.S. код следует оформлять красивенько, найдтите кнопочку <...> на панели. бонус
 
Wild.Godlike, вот код файл много весит
Код
Private Declare Function ActivateKeyboardLayout _
                          Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721
 
Sub PassportAutomatizationDV()
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721 ' изменение на английскую раскладку
x = ActivateKeyboardLayout&(kb_lay_en, 0) ' изменение на английскую раскладку
Dim ProdName, ProdAddress, PrevProdName, PrevProdAddress, ProdS, TwelveP, Serial, PrevSerial, Pass, mnumber, Passpath, Errorbox, PrintSetBox, thirteen As String, k, Qty, c As Integer
c = 0
On Error GoTo 1:
PrintSetBox = MsgBox("Вы правильно указали настройки принтера (Компоновка: 2 стр. на лист; Двусторонняя печать: переворачивать относительно короткого края)?", vbYesNo)
If PrintSetBox = vbNo Then Exit Sub
Passpath = ActiveDocument.Path & "/DeltaV/" 'Путь к паспортам (впоследствии изменить на папку из ворка, пока же папка находится в одной директории с настоящим файлом)
2:
mnumber = InputBox("Введите код комплекта", "Введение кода комплекта") 'Сканирование кода комплекта
If mnumber = "" Then Exit Sub
TwelveP = InputBox("Введите номер модели (12Pxxxx или 13Pxxx или SDN...)", "Введение номера модели")
If Left(TwelveP, 3) = "12P" And Left(TwelveP, 7) <> "12P4448" And Left(TwelveP, 7) <> "12P4449" And Left(TwelveP, 7) <> "12P4450" And Left(TwelveP, 7) <> "12P4451" And Left(TwelveP, 7) <> "12P4452" And Left(TwelveP, 7) <> "12P4453" And Left(TwelveP, 7) <> "12P4454" And Left(TwelveP, 7) <> "12P4455" And Left(TwelveP, 7) <> "12P4456" And Left(TwelveP, 7) <> "12P4983" Then
Pass = Left(TwelveP, 7) 'Сканирование 12P-номера
Else
If Left(TwelveP, 3) = "13P" Then 'определяет 13Р- номера по первым 7 символам
Pass = Left(TwelveP, 7)
Else
Pass = TwelveP
End If
End If
If Pass = "" Then Exit Sub
If Left(mnumber, 1) = "R" Then
Pass = Pass & Left(mnumber, 1)
End If
Documents.Open (Passpath & Pass & ".docx") 'открытие файла с шаблоном паспорта
Qty = InputBox("Введите количество паспортов", "Введение количества паспортов")
For k = 1 To Qty
3:
    Serial = InputBox("Введите серийный номер", "Введение серийного номера, осталось паспортов: " & Qty - c)
    If Left(Serial, 3) = "12P" Or Left(Serial, 3) = "002" Or Left(Serial, 3) = "13p" Then
    MsgBox "Неправильно введен серийный номер", vbOKOnly, "Ошибка при вводе серийного номера"
    GoTo 3:
    End If
    ProdS = Left(Serial, 1)
    If Serial = "" Then
    Application.DisplayAlerts = False
    ActiveDocument.Close (False) 'закрытие документа для обновления полей
    Application.DisplayAlerts = True
    Exit Sub
    End If
    Select Case ProdS
    Case Is = "M"
    ProdName = "MTL"
    ProdAddress = "Great Marlings, Butterfield, Luton LU2 8DL"
    Case Is = "L"
    ProdName = "Fisher Rosemount"
    ProdAddress = "Meridan East, Leicester, LEI9 1UX"
    Case Is = "A"
    ProdName = "Fisher Rosemount"
    ProdAddress = "1100 West Louis Henna Blvd. Bldg. 1, Round Rock, Texas, 78681-7430"
    Case Is = "3"
    ProdName = "Fisher Rosemount"
    ProdAddress = "1100 West Louis Henna Blvd. Bldg. 1, Round Rock, Texas, 78641 USA"
    Case Is = "T"
    ProdName = "Benchmark Electronics"
    ProdAddress = "94 Moo 1, Hi-Tech Industrial Estate, Banlane, Bang Pa-In, Ayudhaya 13160"
    Case Is = "S"
    ProdName = "P & F"
    ProdAddress = "Great Marlings, Butterfield, Luton LU2 8DL"
    Case Is = "M"
    ProdName = "Astec"
    ProdAddress = "Main Road Cor. Road J, Cavite Economic Zone Authority Tejeros Convention, Rosario, Cavite, 4106"
    Case Is = "F"
    ProdName = "Astec"
    ProdAddress = "104 Laguna Blvd., Laguna Technopark Sta.Rosa, Laguna, Philippines 4026"
    Case Is = "O"
    ProdName = "Orienson"
    ProdAddress = "7th Team lndustrial Zone,Xi'niupo Village,Dalang Town,Dongguan City,Guangdong Province"
    Case Is = "J"
    ProdName = "Jinpao"
    ProdAddress = "631 Moo Soi 12 Phraksa, Amphur Muang, Samutprakarn 10280"
    Case Is = "P"
    If Left(Serial, 2) = "PH" Then
    ProdName = "Astec Power Phillipines inc."
    ProdAddress = "Main Ave, Corner Road J, PEZA Complex, Rosario, 4106 Cavite"
    Else
    ProdName = "Benchmark Electronics"
    ProdAddress = "Malaysia, Free Industrial Zone, Phase 1, Bayan Lepas, 11900"
    End If
    Case Is = "N"
    ProdName = "Nation Gate"
    ProdAddress = "1413, Solok Perusahaan Satu, Kawasan Perindustrian Prai, Prai, 13600, Malaysia, 13600 Perai"
    Case Is = "H"
    ProdName = "Hotayi"
    ProdAddress = "Taman Iks Bkt Tengah, 14000 Bukit Mertajam"
    Case Is = "K"
    ProdName = "Benchmark Electronics"
    ProdAddress = "Thailand, 109 Moo 4, Tambol Chaimongkol, Amphur Muang, Nakornrachasima 30000"
    Case Is = "C"
    ProdName = "Puls"
    ProdAddress = "Prague 5639, 430 01 Chomutov"
    Case Is = "B"
    ProdName = "Kin Fat"
    ProdAddress = "FLAT G, 5/F, BLOCK 2, WAH FUNG IND. CENTRE, 33-39 KWAI FUNG CRESCENT, KWAI CHUNG, N.T., HONG KONG"
    Case Is = "E"
    ProdName = "Jabil"
    ProdAddress = "China, Huangpu, 128 JunCheng Road., Huangpu Economic and Technological Development District, PRC 510530 Guangdong Province"
    Case Is = "R"
    ProdName = "Jabil"
    ProdAddress = "China, Huangpu, 128 JunCheng Road., Huangpu Economic and Technological Development District, PRC 510530 Guangdong Province"
    Case Is = "D"
    ProdName = "Филиал ООО ''Эмерсон''"
    ProdAddress = "454003, Российская Федерация, Челябинская область, город Челябинск, проспект Новоградский, дом 15"
    Case Is = "X"
    ProdName = "Xian Technology"
    ProdAddress = "3F R&D Building Xi'an Software Park, 34 1st Jinye Rd., Xi'an High-Tech Industrial Zone"
    Case Is = "U"
    ProdName = "Phoenix Contact"
    ProdAddress = "586 Fulling Mill Rd, Middletown, PA 17057"
    Case Is = "9"
    ProdName = "Hirschmann Automation and Control GmbH."
    ProdAddress = "Germany, Stuttgarter Strasse 45-51, 72654 Neckartenzlingen"
    Case Is = "1"
    ProdName = "Fisher-Rosemount Systems, inc."
    ProdAddress = "USA, 1100 W.Louis Henna Blvd. Round Rock, TX 78681"
    Case Else
    MsgBox "Неправильно введен серийный номер", vbOKOnly, "Ошибка при вводе серийного номера"
    GoTo 3:
    End Select
    With ActiveDocument.Range.Find
        .ClearFormatting
        .Text = "mnumber"
        .Replacement.Text = mnumber
        .Execute Replace:=wdReplaceAll
        .Text = "serialnumber"
        .Replacement.Text = Serial
        .Execute Replace:=wdReplaceAll
        .Text = PrevSerial
        .Replacement.Text = Serial
        .Execute Replace:=wdReplaceAll
        .Text = "currentdate"
        .Replacement.Text = Date
        .Execute Replace:=wdReplaceAll
        .Text = "ProdName"
        .Replacement.Text = ProdName
        .Execute Replace:=wdReplaceAll
        .Text = "ProdAddress"
        .Replacement.Text = ProdAddress
        .Execute Replace:=wdReplaceAll
        .Text = PrevProdName
        .Replacement.Text = ProdName
        .Execute Replace:=wdReplaceAll
        .Text = PrevProdAddress
        .Replacement.Text = ProdAddress
        .Execute Replace:=wdReplaceAll
        PrevSerial = Serial
        PrevProdName = ProdName
        PrevProdAddress = ProdAddress
    End With
    Application.PrintOut FileName:="", Range:=wdPrintRangeOfPages, Item:= _
    wdPrintDocumentWithMarkup, Copies:=1, Pages:="4,1,2,3", PageType:= _
    wdPrintAllPages, Collate:=True, Background:=False, PrintToFile:=False, _
    PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
    PrintZoomPaperHeight:=0  'вывод на печать
    
 

    
    c = c + 1
    Next k
    Application.DisplayAlerts = False
    ActiveDocument.Close (False) 'закрытие документа для обновления полей
    Application.DisplayAlerts = True
Exit Sub
1:
Errorbox = MsgBox("Неправильно введены данные, продолжить выполнение программы?", vbYesNo)
If Errorbox = vbNo Then
Application.DisplayAlerts = False
ActiveDocument.Close (False) 'закрытие документа для обновления полей
Application.DisplayAlerts = True
Exit Sub
End If
Resume 2:
End Sub
не знал про эти ковычки, спасибо)
Изменено: Anri_amar - 23.06.2020 09:49:12
 
Цитата
Anri_amar написал:
внедрить что бы он еще и сохранял это файл в пдф,
Включите макрорекордер, сохраните лист в формате pdf, посмотрите, что макрорек. записал. Добавьте после того, что у Вас в сообщ. #1.
Только надо придумать, как задавать название файла.
Изменено: Михаил Лебедев - 23.06.2020 13:05:35
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Михаил Лебедев, да, так можно сделать, но видите, макрос который я приложил, запускает шаблон уже сужествующегося паспорта, в котором меняет данные серийного номера, дату и еще некоторые параметры. Напрмер:  передо мной лежит 10 единиц оборудования с разными серийниками, я говрю макросу какой шаблон из папки загрузить, он его загрущает, далее он меня спрашивает сколько будет этих паспортов для этого шаблона, я ему говрю 10, и тогда он запрашивает серийник первого модуля, и так далее 10 раз он будет запрашивать сериник, дак вот мне нужно что бы он сохранял каждый паспорт в папку с именем серийника,который я ввел, Как сделать что бы фалый сохранялись с именем сериника?
Вот то что получилось, с макрорекодером, по идеи работает, но не так как надо.
Код
Sub Макрос2()
'
' Макрос2 Макрос
'
'
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        "C:\Work\Автоматизация паспортов\Паспорта готовые\D123456789.pdf", _ 'Вот тут имяфайла, если все так и оставить в макросе, то это имя и будет всезгда сохраняться, сюда бы условие какое воткнуть
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    ChangeFileOpenDirectory _
        "C:\Work\Автоматизация паспортов\Паспорта готовые\"
End Sub
Изменено: Anri_amar - 25.06.2020 06:41:15
 
Без файла трудно разобраться. Но всё же. Вот фрагмент Вашего кода:
Код
For k = 1 To Qty3:
    Serial = InputBox("Введите серийный номер", "Введение серийного номера, осталось паспортов: " & Qty - c)
    If Left(Serial, 3) = "12P" Or Left(Serial, 3) = "002" Or Left(Serial, 3) = "13p" Then
    MsgBox "Неправильно введен серийный номер", vbOKOnly, "Ошибка при вводе серийного номера"
Я так понимаю, что Serial - это как раз и есть та переменная, которой Вы присваиваете серийный номер.
тогда так, наверно?
Код
Sub Макрос2(Serial)        
    Dim MyPath as string
    MyPath = "C:\Work\Автоматизация паспортов\Паспорта готовые\"

    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        MyPath & Serial & ".pdf", _ 'Вот тут имяфайла, если все так и оставить в макросе, то это имя и будет всезгда сохраняться, сюда бы условие какое воткнуть        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    ChangeFileOpenDirectory _
        MyPath 
End Sub
А в Вашем коде из сообщения #3 вместо пустой строки 162 напишите
Код
Макрос2 Serial ' Сохранение паспорта
Изменено: Михаил Лебедев - 25.06.2020 09:40:21
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Михаил Лебедев, спасибо, нужно было в ковычки перменную с сериными номерами заключить, я до этого не дошел сразу.
Страницы: 1
Наверх