Last active
February 18, 2020 20:55
-
-
Save Osmiogrzesznik/38c9bcd9ab6a2f43aec249cb39b04d95 to your computer and use it in GitHub Desktop.
opens dialog, all selected files are inserted with captions containing chapter indices - filename as the caption content
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Sub InsertMultipleImages() | |
Dim fd As FileDialog | |
Dim oTbl As Table | |
Dim oILS As InlineShape | |
Dim oRng As Range | |
Dim rngHead As Range | |
Dim vrtSelectedItem As Variant | |
If Documents.Count = 0 Then | |
If MsgBox("No document open!" & vbCr & vbCr & _ | |
"Do you wish to create a new document to hold the images?", _ | |
vbYesNo, "Insert Images") = vbYes Then | |
Documents.Add | |
Else | |
Exit Sub | |
End If | |
End If | |
'Add a 1 row 2 column table to take the images | |
'Set oTbl = Selection.Tables.Add(Selection.Range, 1, 2) | |
' oTbl.AutoFitBehavior (wdAutoFitFixed) | |
Dim currentChapter | |
Set oRng = Selection.Range | |
Set rngHead = oRng.GoTo(what:=wdGoToHeading, Which:=wdGoToPrevious, Count:=1).Paragraphs(1).Range | |
rngHead.MoveEnd Unit:=wdCharacter, Count:=-1 | |
currentChapter = rngHead.Text | |
With CaptionLabels(wdCaptionFigure) | |
.IncludeChapterNumber = True | |
.ChapterStyleLevel = 2 | |
.NumberStyle = wdCaptionNumberStyleArabic | |
End With | |
' Selection.InsertCaption Label:="Figure", TitleAutoText:="", Title:="." & _ | |
' " " & currentChapter, Position:=wdCaptionPositionBelow, ExcludeLabel:=0 | |
If MsgBox("Chapter no " & vbCr & currentChapter & _ | |
"", _ | |
vbYesNo, "Insert Images") = vbNo Then | |
Exit Sub | |
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 | |
Dim i As Integer | |
i = 0 | |
'prepare some space | |
For Each vrtSelectedItem In .SelectedItems | |
Selection.InsertAfter (vbCr) | |
Next vrtSelectedItem | |
Selection.MoveUp Unit:=wdLine, Count:=1 | |
Selection.GoToNext what:=wdGoToLine | |
For Each vrtSelectedItem In .SelectedItems | |
Dim fName As String | |
Dim fFolderName As String | |
fName = Right$(vrtSelectedItem, Len(vrtSelectedItem) - InStrRev(vrtSelectedItem, "\")) | |
fFolderName = Right$(vrtSelectedItem, Len(vrtSelectedItem) - InStrRev(vrtSelectedItem, "\")) | |
i = i + 1 | |
With Selection | |
Set oILS = .InlineShapes.AddPicture(FileName:= _ | |
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _ | |
Range:=Selection.Range) | |
oILS.Range.InsertCaption Label:="Figure", TitleAutoText:="", Title:="." _ | |
& " " & currentChapter & "-" & fName, Position:=wdCaptionPositionBelow, ExcludeLabel:=0 | |
' .MoveRight wdCell, 1 | |
End With | |
Selection.MoveDown Unit:=wdLine, Count:=2 'move past picture and caption, since insertion doesnt change the position | |
Next vrtSelectedItem | |
Else | |
End If | |
End With | |
'If Len(oTbl.Rows.Last.Cells(1).Range) = 2 Then oTbl.Rows.Last.Delete | |
Set fd = Nothing | |
' With CaptionLabels(wdCaptionTable) | |
' .IncludeChapterNumber = True | |
' .ChapterStyleLevel = 2 | |
'End With | |
End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment