Тема: Помогите создать макрос.
Здравствуйте. Есть 300 сканов в формате .jpg, их нужно закинуть в ворд документ, при этом чтоб они растягивались и центрировались под страницу А4 автоматически.
Спасибо, с уважением.
- Fck_This
- генерал-полковник
- Неактивен
Re: Помогите создать макрос.
Kutsolap пишет:
Здравствуйте. Есть 300 сканов в формате .jpg, их нужно закинуть в ворд документ, при этом чтоб они растягивались и центрировались под страницу А4 автоматически.
Спасибо, с уважением.
Sub GetAllPicsFromFolder()
Dim oFSO, oFolder As Object
Dim oDoc As Document
Dim sFolder, sName, sPathName As String
Dim iHeight, iWidth, iCounter As Integer
Set oDoc = ActiveDocument
iCounter = 0
sFolder = "C:\Users\client606_15\Desktop\Pictures" 'Путь к папке
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolder) Then
Set oFolder = oFSO.GetFolder(sFolder)
For Each oFile In oFolder.Files
sName = oFile.Name
'Можно указать свой формат рисунка
If InStr(sName, ".jpg") >= 1 Or InStr(sName, ".png") >= 1 Then
sPathName = sFolder & "\" & sName
iHeight = Selection.PageSetup.PageHeight
iWidth = Selection.PageSetup.PageWidth
Application.Selection.Range.InlineShapes.AddPicture sPathName, LinkToFile:=False, SaveWithDocument:=True
iCounter = iCounter + 1
oDoc.InlineShapes(iCounter).Height = iHeight
oDoc.InlineShapes(iCounter).Width = iWidth
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
End If
Next oFile
End If
MsgBox "Все файлы внесены"
End SubСпасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871
Re: Помогите создать макрос.
Fck_This пишет:
. . . iHeight = Selection.PageSetup.PageHeight iWidth = Selection.PageSetup.PageWidth . . . oDoc.InlineShapes(iCounter).Height = iHeight oDoc.InlineShapes(iCounter).Width = iWidth . . .
При таком подходе преобразованные картинки могут исказиться, напр., квадратные по исходным размерам картинки станут вытянутыми под формат A4. Это надо проверить. Если искажение возможно, а для пользователя это недопустимо, то можно было бы применить такой подход: попытаться увеличивать исходный размер в цикле, пока не будет превзойдена целевая высота или ширина (что-то произойдет раньше) - тогда цикл закончить, а наработанные значения ширины и высоты присвоить рисунку. Эти вычисления не сильно затормозят макрос.
- Fck_This
- генерал-полковник
- Неактивен
Re: Помогите создать макрос.
Можно растянуть по ширине и включить функцию сохранения соотношений. Про центрирование забыл. Хотя если подразумевается по ширине - то при изменении размеров под лист - они и так по центру будут
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871