Option Explicit
Sub AKInsertImages()
' v2 31 December 2014
Dim doc As Word.Document
Dim fd As FileDialog
Dim vItem As Variant
Dim mg1 As Range
Dim mg2 As Range
Dim intCount As Integer
Dim strTotal As String
strTotal = ""
intCount = 0
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set doc = ActiveDocument
Dim shapePicture As InlineShape
Dim intSetWidth As Integer
Dim intSetHeight As Integer
' **************************************
intSetWidth = 375
intSetHeight = 400
' **************************************
Dim dblPercentResize As Double
dblPercentResize = 1
' **************************************
' Get Title, Description, Taken By
' **************************************
' eg
' Bicycle Robbery 13 November 2014.
' Taken By: Detective MCGILL. Image: 9 of 9
' Desc:
Dim strCaseTitle As String
Dim strTakenBy As String
strCaseTitle = InputBox("Case Title", "Please enter case title")
strTakenBy = InputBox("Photographed By", "Please enter who took the photo")
With fd
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp", 1
.FilterIndex = 1
If .Show = -1 Then
For Each vItem In .SelectedItems
intCount = intCount + 1
Set mg2 = ActiveDocument.Range
mg2.Collapse wdCollapseEnd
Set shapePicture = doc.InlineShapes.AddPicture( _
FileName:=vItem, _
LinkToFile:=False, SaveWithDocument:=True, Range:=mg2)
' if we are wider than we want, resize percentage
If shapePicture.Width > intSetWidth Then
dblPercentResize = CDbl(intSetWidth / shapePicture.Width)
shapePicture.Width = shapePicture.Width * dblPercentResize
shapePicture.Height = shapePicture.Height * dblPercentResize
End If
' if we are higher than we want, resize percentage
If shapePicture.Height > intSetHeight Then
dblPercentResize = CDbl(intSetHeight / shapePicture.Height)
shapePicture.Width = shapePicture.Width * dblPercentResize
shapePicture.Height = shapePicture.Height * dblPercentResize
End If ' height
Set mg1 = ActiveDocument.Range
mg1.Collapse wdCollapseEnd
strTotal = CStr(.SelectedItems.Count)
mg1.Text = ""
mg1.Text = vbCrLf + "Image: " + CStr(intCount) + " of " + strTotal
mg1.Text = mg1.Text + vbCrLf + strCaseTitle
mg1.Text = mg1.Text + vbCrLf + "Taken By:" + strTakenBy
mg1.Text = mg1.Text + vbCrLf + "Description:"
' mg1.Text = mg1.Text + vbCrLf + "width=" + CStr(shapePicture.Width) + " height " + CStr(shapePicture.Height)
' mg1.Text = mg1.Text + vbCrLf + "Percentage used = " + CStr(dblPercentWidth)
mg1.Text = mg1.Text + vbCrLf & vbCrLf
Next vItem
End If
End With
Set fd = Nothing
End Sub
' AKInsertImages
