VBA Word add captions to images, add max height criterion

问题

I have here a nice algorithm, that adds serveral pictures to a word document and gives as caption the filename without extension, for me it is very usefull and productive, I share the code below, I recommend it for large documents/reports.

I need to improve this code by giving a max height or Width to the image in the document, so it wont ocupy that much space. can anyone give a hint how to do that fast and easy? maybe with the Shaperange-object? see VBA-documentation

Option Explicit

Sub VieleFigurenMitTitel()
Dim fd As FileDialog
Dim picName As Variant
Dim TitleText As Variant
Dim oTable As Table
Dim sNoDoc As String
Dim vrtSelectedItem As Variant
Dim fso As New FileSystemObject
If Documents.Count = 0 Then
sNoDoc = MsgBox(" " & _
"No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images")
If sNoDoc = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
TitleText = InputBox("Abbildung/Figura/Figure", "Namen geben", "Figura")
For Each vrtSelectedItem In .SelectedItems
picName = Split(fso.GetFileName(vrtSelectedItem), ".") 'picName holds the picture name
With Selection
'.ShapeRange.LockAspectRatio msoTrue
.ShapeRange.Width 0.5, msoTrue ' this does not work
.ShapeRange.ScaleHeight 0.5, msoFalse ' this does not work
.InlineShapes.AddPicture fileName:=vrtSelectedItem
Selection.TypeParagraph
Selection.InsertCaption Label:=TitleText, TitleAutoText:="", Title:=": " & picName(0), _
Position:=wdCaptionPositionBelow
Selection.TypeParagraph
End With
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing
End Sub

来源：https://stackoverflow.com/questions/35359351/vba-word-add-captions-to-images-add-max-height-criterion

标签

vba

ms-word

word-vba