Коллеги, привет!
Есть ли идеи как проигнорировать диалоговое окно при открытии PDF?
Пробовал так, но не помогло:
Есть ли идеи как проигнорировать диалоговое окно при открытии PDF?
Пробовал так, но не помогло:
| Код |
|---|
ConfirmConversions = False Visible = True |
| Код |
|---|
Sub ConvertRangeToPDF_WordEngin2()
Dim rng As Range
Dim cell As Range
Dim filesList As New Collection
Dim i As Long
Dim outputPath As String
Dim wdApp As Object, wdDoc As Object, wdSel As Object
Dim wasOpen As Boolean
Dim fPath As String
Dim fileExt As String
' ---- 1. Чтение путей из диапазона E7:E18 ----
On Error Resume Next
Set rng = ThisWorkbook.ActiveSheet.Range("E7:E18")
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Не удалось получить диапазон E7:E18", vbExclamation
Exit Sub
End If
For Each cell In rng
fPath = Trim(cell.Value)
If fPath <> "" Then
If Dir(fPath) <> "" Then
filesList.Add fPath
Else
Debug.Print "Файл не найден: " & fPath
End If
End If
Next cell
If filesList.Count = 0 Then
MsgBox "Нет доступных файлов в диапазоне E7:E18!", vbExclamation
Exit Sub
End If
' ---- 2. Настройки (только для изображений) ----
Dim pageSize As String
pageSize = InputBox("Выберите размер страницы для ИЗОБРАЖЕНИЙ:" & vbCrLf & vbCrLf & _
"1 - A4 (210 x 297 мм)" & vbCrLf & _
"2 - A3 (297 x 420 мм)" & vbCrLf & _
"3 - Letter (216 x 279 мм)" & vbCrLf & _
"4 - Подогнать под размер картинки" & vbCrLf & _
"5 - Квадрат (210 x 210 мм)", _
"Настройки PDF", "1")
If pageSize = "" Then Exit Sub
Dim orientation As String
orientation = InputBox("Ориентация страницы для ИЗОБРАЖЕНИЙ:" & vbCrLf & vbCrLf & _
"1 - Книжная (портрет)" & vbCrLf & _
"2 - Альбомная (ландшафт)" & vbCrLf & _
"3 - Авто (по ориентации картинки)", _
"Ориентация", "3")
If orientation = "" Then Exit Sub
' ---- 3. Путь сохранения ----
outputPath = Application.GetSaveAsFilename( _
InitialFileName:="Output.pdf", _
FileFilter:="PDF (*.pdf), *.pdf", _
Title:="Сохранить PDF")
If outputPath = "False" Then Exit Sub
If LCase(Right(outputPath, 4)) <> ".pdf" Then outputPath = outputPath & ".pdf"
' ---- 4. Инициализация Word ----
Application.StatusBar = "Запуск Word..."
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
wasOpen = Not (wdApp Is Nothing)
On Error GoTo 0
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
End If
wdApp.Visible = True
wdApp.DisplayAlerts = False
Set wdDoc = wdApp.Documents.Add
Set wdSel = wdApp.Selection
' Константы Word
Const wdSectionBreakNextPage As Long = 3
Const wdOrientPortrait As Long = 1
Const wdOrientLandscape As Long = 0
Const wdSaveFormatPDF As Long = 17
Const wdCollapseEnd As Long = 0
Dim isFirstItem As Boolean
isFirstItem = True
' ---- 5. Обработка файлов ----
For i = 1 To filesList.Count
Application.StatusBar = "Обработка " & i & "/" & filesList.Count & "..."
DoEvents
fPath = filesList(i)
fileExt = LCase(Right(fPath, Len(fPath) - InStrRev(fPath, ".")))
' Добавляем разрыв раздела (кроме первого элемента)
If Not isFirstItem Then
wdSel.InsertBreak wdSectionBreakNextPage
wdSel.Collapse wdCollapseEnd
End If
isFirstItem = False
' ---- Обработка PDF ----
If fileExt = "pdf" Then
On Error Resume Next
' Используем InsertFile - вставляет содержимое напрямую
wdSel.InsertFile Filename:=fPath
If Err.Number <> 0 Then
Debug.Print "Не удалось вставить PDF: " & fPath
Err.Clear
End If
On Error GoTo 0
' Переходим в конец вставленного содержимого
wdSel.Collapse wdCollapseEnd
' ---- Обработка Изображений ----
ElseIf fileExt = "jpg" Or fileExt = "jpeg" Or fileExt = "png" Or _
fileExt = "bmp" Or fileExt = "gif" Or fileExt = "tif" Or fileExt = "tiff" Then
Dim inlinePic As Object
Set inlinePic = wdSel.InlineShapes.AddPicture(Filename:=fPath, LinkToFile:=False, SaveWithDocument:=True)
Dim imgW As Single, imgH As Single
imgW = inlinePic.Width
imgH = inlinePic.Height
With wdSel.PageSetup
.TopMargin = 0
.BottomMargin = 0
.LeftMargin = 0
.RightMargin = 0
' 1. Установка размера страницы
Select Case pageSize
Case "1": .PageWidth = 595.28: .PageHeight = 841.89 ' A4
Case "2": .PageWidth = 841.89: .PageHeight = 1190.55 ' A3
Case "3": .PageWidth = 612: .PageHeight = 792 ' Letter
Case "5": .PageWidth = 595.28: .PageHeight = 595.28 ' Квадрат
Case "4"
If imgW > 1587 Or imgH > 1587 Then
Dim ratio As Single
ratio = 1587 / IIf(imgW > imgH, imgW, imgH)
.PageWidth = imgW * ratio
.PageHeight = imgH * ratio
inlinePic.Width = .PageWidth
inlinePic.Height = .PageHeight
Else
.PageWidth = imgW
.PageHeight = imgH
End If
Case Else: .PageWidth = 595.28: .PageHeight = 841.89
End Select
' 2. Установка ориентации
If pageSize = "4" Then
If .PageWidth > .PageHeight Then .orientation = wdOrientLandscape
If .PageHeight > .PageWidth Then .orientation = wdOrientPortrait
Else
If orientation = "3" Then ' Авто
If imgW > imgH Then
.orientation = wdOrientLandscape
Else
.orientation = wdOrientPortrait
End If
ElseIf orientation = "2" Then ' Альбомная
.orientation = wdOrientLandscape
Else ' Книжная
.orientation = wdOrientPortrait
End If
End If
End With
' 3. Масштабирование картинки
If pageSize <> "4" Then
Dim availW As Single, availH As Single
availW = wdSel.PageSetup.PageWidth - wdSel.PageSetup.LeftMargin - wdSel.PageSetup.RightMargin
availH = wdSel.PageSetup.PageHeight - wdSel.PageSetup.TopMargin - wdSel.PageSetup.BottomMargin
Dim scX As Single, scY As Single, sc As Single
inlinePic.LockAspectRatio = False
scX = availW / imgW
scY = availH / imgH
sc = IIf(scX < scY, scX, scY)
inlinePic.LockAspectRatio = True
inlinePic.Width = imgW * sc
inlinePic.Height = imgH * sc
wdSel.ParagraphFormat.Alignment = 1 ' Центр
Else
wdSel.ParagraphFormat.Alignment = 1
End If
wdSel.ParagraphFormat.SpaceBefore = 0
wdSel.ParagraphFormat.SpaceAfter = 0
End If
Next i
' ---- 6. Экспорт в PDF ----
Application.StatusBar = "Сохранение PDF..."
wdDoc.SaveAs2 Filename:=outputPath, FileFormat:=wdSaveFormatPDF
wdDoc.Close SaveChanges:=False
If Not wasOpen Then wdApp.Quit
Application.StatusBar = False
MsgBox "PDF успешно создан!" & vbCrLf & _
"Файл: " & outputPath & vbCrLf & _
"Обработано файлов: " & filesList.Count, vbInformation
End Sub
|
Изменено: - 30.03.2026 13:03:03
(примеры промптов, использование моделей в различных задачах и т.д.)
