Option Explicit
Sub aaInsertImagesOneToAPage()
'-- v1.1 4/10/2017 - Add option to check for landscape v portrait and adjust sizes accordingly, and max height
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
' Set the width or the height
Dim intSetWidth
Dim intSetHeight
Dim intMaxHeight As Integer
If Selection.PageSetup.Orientation = wdOrientLandscape Then
intSetWidth = 550 '
intSetHeight = 350 '
intMaxHeight = 350
Else
intSetWidth = 350 '
intSetHeight = 350 '
intMaxHeight = 300
End If
Dim dblPercentChange As Double
dblPercentChange = 1
'==Prompt user for Case Title:
Dim strCaseTitle As String
strCaseTitle = InputBox("Enter a title for the case :", "Case Title1")
Dim blImageAdjusted As Boolean
With fd
.Filters.Clear
'== .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp *.png", 1 remove filters so we can add png images
'== .FilterIndex = 1
blImageAdjusted = False
If .Show = -1 Then
For Each vItem In .SelectedItems
intCount = intCount + 1
Set mg2 = ActiveDocument.Range
mg2.ParagraphFormat.Alignment = wdAlignParagraphCenter
mg2.Collapse wdCollapseEnd
Set shapePicture = doc.InlineShapes.AddPicture( _
FileName:=vItem, _
LinkToFile:=False, SaveWithDocument:=True, Range:=mg2)
' Resize portait and landscape picture differently
' Resize portrait by height and resize landscape by width
' Portrait - resize by height
If shapePicture.Height > shapePicture.Width Then
' if we are not the height we we want, resize by percent
If shapePicture.Height <> intSetHeight Then
blImageAdjusted = True
dblPercentChange = CDbl(intSetHeight / shapePicture.Height)
shapePicture.Width = shapePicture.Width * dblPercentChange
shapePicture.Height = shapePicture.Height * dblPercentChange
End If
Else
' this is for square or landscape images
If shapePicture.Width <> intSetWidth Then
blImageAdjusted = True
dblPercentChange = CDbl(intSetWidth / shapePicture.Width)
shapePicture.Width = shapePicture.Width * dblPercentChange
shapePicture.Height = shapePicture.Height * dblPercentChange
End If
End If ' Portrait or Landscape
' final check if we are too big
If shapePicture.Height > intMaxHeight Then
dblPercentChange = intMaxHeight / shapePicture.Height
shapePicture.Width = shapePicture.Width * dblPercentChange
shapePicture.Height = shapePicture.Height * dblPercentChange
End If
Set mg1 = ActiveDocument.Range
mg1.Collapse wdCollapseEnd
strTotal = CStr(.SelectedItems.Count)
If strCaseTitle <> "" Then
mg1.Text = ""
mg1.Text = vbCrLf + strCaseTitle + ". "
mg1.Text = mg1.Text + "Height wanted = " + CStr(intSetHeight) + "Actual height now=" + CStr(shapePicture.Height)
mg1.Text = mg1.Text + " Height Percent=" + CStr(dblPercentChange)
mg1.Text = mg1.Text + "Image: " + CStr(intCount) + " of " + strTotal
mg1.Text = mg1.Text + vbCrLf + "width now =" + CStr(shapePicture.Width) + " height now " + CStr(shapePicture.Height)
If blImageAdjusted Then
mg1.Text = mg1.Text + vbCrLf + "Image WAS adjusted" & vbCrLf
Else
mg1.Text = mg1.Text + vbCrLf + "Image was NOT adjusted" & vbCrLf
End If ' was image adjusted
End If ' strCaseTitle is blank
'Insert a page break
mg1.InsertBreak (7)
Next vItem
End If
End With
Set fd = Nothing
End Sub ' InsertImagesOfHeight
Sub aaInsertImagesOneToAPageReverse()
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
' Set the width or the height
Dim intSetWidth
Dim intSetHeight
intSetWidth = 350
intSetHeight = 350
Dim dblPercentChange As Double
dblPercentChange = 1
'==Prompt user for Case Title:
Dim strCaseTitle As String
strCaseTitle = InputBox("Enter a title for the case :", "Case Title")
Dim blImageAdjusted As Boolean
With fd
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp", 1
.FilterIndex = 1
blImageAdjusted = False
If .Show = -1 Then
For Each vItem In .SelectedItems
intCount = intCount + 1
Set mg2 = ActiveDocument.Range
mg2.ParagraphFormat.Alignment = wdAlignParagraphCenter
mg2.Collapse wdCollapseEnd
mg2.GoTo
Set shapePicture = doc.InlineShapes.AddPicture( _
FileName:=vItem, _
LinkToFile:=False, SaveWithDocument:=True, Range:=mg2)
' Resize portait and landscape picture differently
' Resize portrait by height and resize landscape by width
' Portrait - resize by height
If shapePicture.Height > shapePicture.Width Then
' if we are not the height we we want, resize by percent
If shapePicture.Height <> intSetHeight Then
blImageAdjusted = True
dblPercentChange = CDbl(intSetHeight / shapePicture.Height)
shapePicture.Width = shapePicture.Width * dblPercentChange
shapePicture.Height = shapePicture.Height * dblPercentChange
End If
Else
' this is for square or landscape images
If shapePicture.Width <> intSetWidth Then
blImageAdjusted = True
dblPercentChange = CDbl(intSetWidth / shapePicture.Width)
shapePicture.Width = shapePicture.Width * dblPercentChange
shapePicture.Height = shapePicture.Height * dblPercentChange
End If
End If ' Portrait or Landscape
Set mg1 = ActiveDocument.Range
mg1.Collapse wdCollapseEnd
strTotal = CStr(.SelectedItems.Count)
If strCaseTitle <> "" Then
mg1.Text = ""
mg1.Text = vbCrLf + strCaseTitle + ". "
mg1.Text = mg1.Text + "Height wanted = " + CStr(intSetHeight) + "Actual height=" + CStr(shapePicture.Height)
mg1.Text = mg1.Text + " Height Percent=" + CStr(dblPercentChange)
mg1.Text = mg1.Text + "Image: " + CStr(intCount) + " of " + strTotal
mg1.Text = mg1.Text + vbCrLf + "width=" + CStr(shapePicture.Width) + " height " + CStr(shapePicture.Height)
If blImageAdjusted Then
mg1.Text = mg1.Text + vbCrLf + "Image WAS adjusted" & vbCrLf
Else
mg1.Text = mg1.Text + vbCrLf + "Image was NOT adjusted" & vbCrLf
End If ' was image adjusted
End If ' strCaseTitle is blank
'Insert a page break
mg1.InsertBreak (7)
Next vItem
End If
End With
Set fd = Nothing
End Sub ' InsertImagesReverse
Sub InsertImages3ToAPage()
Call InsertImagesNoBiggerThan(170)
End Sub
Sub InsertImages()
Call aaInsertImagesOneToAPage
End Sub 'InsertImages()
Sub AddinUserDetailsDetach()
'
' AddinUserDetailsDetach Macro
'
'
End Sub
Sub aSetAllPicturesSize()
Dim i As Long
Dim strNewWidth As String
strNewWidth = InputBox("Enter a width for all images: (eg 450)", "Image Size")
Dim intNewWidth As Integer
intNewWidth = CInt(strNewWidth)
Dim intNewHeight As Integer
intNewHeight = CInt(intNewWidth * 0.8)
Dim dblPercentChange As Double
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
If .Height > .Width Then
' if we are not the height we we want, resize by percent
If .Height <> intNewHeight Then
dblPercentChange = CDbl(intNewHeight / .Height)
.Width = .Width * dblPercentChange
.Height = .Height * dblPercentChange
End If
Else
' this is for square or landscape images
If .Width <> intNewWidth Then
dblPercentChange = CDbl(intNewWidth / .Width)
.Width = .Width * dblPercentChange
.Height = .Height * dblPercentChange
End If
End If ' Portrait or Landscape
End With
Next i
End With
End Sub
Sub aReverseImages()
Dim i As Long
' set up a new space at end of document
Dim rangeEndOfDocument As Range
Dim doc As Word.Document
Set rangeEndOfDocument = ActiveDocument.Range
rangeEndOfDocument.ParagraphFormat.Alignment = wdAlignParagraphCenter
Dim intNumberOfImages As Integer
intNumberOfImages = ActiveDocument.InlineShapes.Count
Dim newIndexOfImages As Integer
newIndexOfImages = intNumberOfImages + 1
With ActiveDocument
For i = intNumberOfImages To 1 Step -1
' Copy image 50 to image 51, then copy image 49 to image 52, then image 48 to 53, then delete images 0 to number of images.
' With .InlineShapes(i)
' rangeEndOfDocument.FormattedText = .Range.FormattedText
rangeEndOfDocument.Text = rangeEndOfDocument.Text & "i is " & CStr(i)
rangeEndOfDocument.Collapse wdCollapseEnd
' End With '
Next i ' for each image
End With
End Sub
No comments:
Post a Comment