Insert pictures from a DIR expression on a MS Word docs. Resize/crop pictures from a selection basis.

ImageInsert.bas

Option Explicit
Public pictureSizeWidth As Integer
Public pictureSizeHeight As Integer

Public Sub insertPicture(file As String, width As Integer)
    Dim shp As InlineShape
    Set shp = ActiveDocument.InlineShapes.AddPicture( _
        FileName:=file, _
        LinkToFile:=False, _
        SaveWithDocument:=True)
    shp.LockAspectRatio = msoTrue
    'shp.Borders.Enable = True
    'shp.Borders.Item(wdBorderTop).LineStyle = wdLineStyleDot
    'shp.Borders.Item(wdBorderTop).LineWidth = wdLineWidth025pt
    'shp.Borders.Item(wdBorderBottom).LineStyle = wdLineStyleDot
    'shp.Borders.Item(wdBorderBottom).LineWidth = wdLineWidth025pt
    If (width > 0) Then shp.width = width
End Sub

Public Sub insertPictureDir(Optional inDir As String = "?", Optional width As Integer = -1)
    Dim i As Integer, j As Integer
    Dim FNames As Variant
    Dim inDirItem  As Variant
    Dim iFilePath As String
    Dim iFileAttr As Variant
    
    ReDim arr(1000) 'set greater than possible number of files
    If (inDir = "?") Then
        inDir = fileDialog("Image files", "*.jpg|*.bmp|*.png")
    End If
    
    For Each inDirItem In Split(inDir, "|")
        FNames = dir(inDirItem) 'set your own path
        Do Until FNames = ""
            arr(i) = FNames
            i = i + 1
            FNames = dir
        Loop
        ReDim Preserve arr(i)
        QuickSort arr(), LBound(arr), UBound(arr)
        
        For j = i To 1 Step -1
            iFilePath = GetFilenameFromPath(inDirItem) & "\" & arr(j)
            iFileAttr = GetAttr(iFilePath)
            If Not (CBool(iFileAttr And vbDirectory)) Then
                insertPicture GetFilenameFromPath(inDirItem) & "\" & arr(j), width
            End If
        Next
    Next
    
End Sub

Function GetFilenameFromPath(ByVal strPath As String) As String
    GetFilenameFromPath = Left(strPath, InStrRev(strPath, "\"))
End Function

Private Function fileDialog(patternName As String, patternExpr As String) As String
   ' https://msdn.microsoft.com/en-us/library/office/ff196794.aspx
  
   ' Requires reference to Microsoft Office 11.0 Object Library.
 
    Dim fDialog As Office.fileDialog
    Dim varFile As Variant
    Dim patternExprItem As Variant
    Dim varFileArr As Variant
    Dim i As Integer
 
   ' Set up the File Dialog.
    Set fDialog = Application.fileDialog(msoFileDialogFilePicker)
 
    With fDialog
 
      ' Allow user to make multiple selections in dialog box
        .AllowMultiSelect = True
             
      ' Set the title of the dialog box.
        .Title = "Please select one or more files"
 
      ' Clear out the current filters, and add our own.
        .Filters.Clear
        For Each patternExprItem In Split(patternExpr, "|")
            .Filters.Add patternName, patternExprItem
        Next
        .Filters.Add "All Files", "*.*"
 
      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
        If .Show = True Then
 
         'Loop through each file selected and add it to our list box.
            ReDim varFileArr(1 To .SelectedItems.Count)
            i = 1
            For Each varFile In .SelectedItems
                varFileArr(i) = varFile
                i = i + 1
            Next
            fileDialog = Join(varFileArr, "|")
        Else
            fileDialog = ""
        End If
    End With
    
    Set fDialog = Nothing
End Function

Private Sub QuickSort(strArray(), intBottom As Integer, intTop As Integer)
    Dim strPivot As String, strTemp As String
    Dim intBottomTemp As Integer, intTopTemp As Integer
    intBottomTemp = intBottom
    intTopTemp = intTop
    strPivot = strArray((intBottom + intTop) \ 2)
    While (intBottomTemp <= intTopTemp)
        While (strArray(intBottomTemp) < strPivot And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Wend
        While (strPivot < strArray(intTopTemp) And intTopTemp > intBottom)
            intTopTemp = intTopTemp - 1
        Wend
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If
    Wend
     'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSort strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSort strArray, intBottomTemp, intTop
End Sub

Public Sub halfPictures()
    Dim shp As InlineShape
    Dim i As Integer
    For i = 1 To ActiveWindow.Selection.InlineShapes.Count
        Set shp = ActiveWindow.Selection.InlineShapes.Item(i)
        shp.width = shp.width * 0.5
        If (shp.LockAspectRatio <> msoTrue) Then
            shp.Height = shp.Height * 0.5
        End If
    Next
End Sub

Public Sub p90Picture()
    Dim shp As InlineShape
    Dim i As Integer
    For i = 1 To ActiveWindow.Selection.InlineShapes.Count
        Set shp = ActiveWindow.Selection.InlineShapes.Item(i)
        shp.width = shp.width * 0.9
        If (shp.LockAspectRatio <> msoTrue) Then
            shp.Height = shp.Height * 0.9
        End If
    Next
End Sub

Public Sub p110Picture()
    Dim shp As InlineShape
    Dim i As Integer
    For i = 1 To ActiveWindow.Selection.InlineShapes.Count
        Set shp = ActiveWindow.Selection.InlineShapes.Item(i)
        shp.width = shp.width * 1.1
        If (shp.LockAspectRatio <> msoTrue) Then
            shp.Height = shp.Height * 1.1
        End If
    Next
End Sub

Public Sub getPictureSize()

    If (ActiveWindow.Selection.InlineShapes.Count < 1) Then
        MsgBox "Please select 1 picture first."
        Exit Sub
    End If
        
    If (ActiveWindow.Selection.InlineShapes.Count > 1) Then
        MsgBox "First picture in the selection will be used."
    End If
        
    Dim shp As InlineShape
    Dim i As Integer
    
    i = 1
    
    Set shp = ActiveWindow.Selection.InlineShapes.Item(i)
    pictureSizeWidth = shp.width
    pictureSizeHeight = shp.Height
    
    MsgBox "Got it. width: " & pictureSizeWidth & ", height: " & pictureSizeHeight

End Sub

Public Sub cropFitPictures()
    Debug.Print pictureSizeWidth, pictureSizeHeight

    Dim shp As InlineShape
    Dim i As Integer
    
    Dim targetRatio As Double, scaleDemand As Single
    Dim shpWidth As Single, shpHeight As Single
    Dim scaleWidth1 As Single, scaleWidth2 As Single
    Dim scaleHeight1 As Single, scaleHeight2 As Single
    Dim minWidth As Single, minHeight As Single
    Dim pictureSizeAsk As String, pictureSizeAskSplit() As String
    
    If (pictureSizeWidth = 0 Or pictureSizeHeight = 0) Then
        pictureSizeAsk = InputBox("Width, Height, in twips unit", ActiveWindow.Document.Name, "162, 162")
        If (pictureSizeAsk = "") Then
            Exit Sub
        End If
        pictureSizeAskSplit = Split(pictureSizeAsk, ",")
        pictureSizeWidth = CInt(pictureSizeAskSplit(0))
        pictureSizeHeight = CInt(pictureSizeAskSplit(1))
    End If
    
    For i = 1 To ActiveWindow.Selection.InlineShapes.Count
        Set shp = ActiveWindow.Selection.InlineShapes.Item(i)
        shp.LockAspectRatio = msoFalse
        Application.ScreenUpdating = False
        shp.ScaleHeight = 100
        shp.ScaleWidth = 100
        shp.LockAspectRatio = msoTrue
        shp.PictureFormat.CropLeft = 0
        shp.PictureFormat.CropRight = 0
        shp.PictureFormat.CropTop = 0
        shp.PictureFormat.CropBottom = 0
        
        shpWidth = shp.width
        shpHeight = shp.Height
        
        targetRatio = CDbl(pictureSizeHeight) / CDbl(pictureSizeWidth)
        
        scaleWidth1 = shpWidth
        scaleHeight1 = shpWidth * targetRatio
        
        scaleWidth2 = shpHeight / targetRatio
        scaleHeight2 = shpHeight
        
        minWidth = Min(scaleWidth1, scaleWidth2)
        minHeight = Min(scaleHeight1, scaleHeight2)
        
        
        shp.PictureFormat.CropLeft = Max(0, shpWidth - minWidth) / 2
        shp.PictureFormat.CropRight = Max(0, shpWidth - minWidth) / 2
        shp.PictureFormat.CropTop = Max(0, shpHeight - minHeight) / 2
        shp.PictureFormat.CropBottom = Max(0, shpHeight - minHeight) / 2
        
        scaleDemand = pictureSizeWidth / minWidth * 100
        shp.width = minWidth
        shp.Height = minHeight
        shp.ScaleWidth = scaleDemand
        shp.ScaleHeight = scaleDemand
        Application.ScreenUpdating = True
        Application.ScreenRefresh
    Next

End Sub

Public Sub EmbeddingPicture()
    On Error Resume Next
    Dim i As Integer
    
    For i = 1 To ActiveWindow.Document.InlineShapes.Count
        Debug.Print ActiveWindow.Document.InlineShapes(i).LinkFormat.SourceFullName
        ActiveWindow.Document.InlineShapes(i).LinkFormat.BreakLink
        DoEvents
    Next
End Sub

Private Function Min(var1, var2)
    Min = IIf(var1 < var2, var1, var2)
End Function

Private Function Max(var1, var2)
    Max = IIf(var1 > var2, var1, var2)
End Function

Public Sub createSeverityPieChart()

    Dim myTable
    Set myTable = Selection.Tables.Item(1)
    
    myTable.Select
    Selection.Collapse wdCollapseStart
    Selection.MoveDown wdLine, 1, wdMove
    Selection.SelectCell
    Selection.MoveEnd wdCell, 1
    Selection.Rows.Delete
    
    myTable.Select
    Selection.Collapse wdCollapseEnd
    Selection.MoveUp wdLine, 1, wdMove
    Selection.SelectCell
    Selection.Rows.Delete

    myTable.Select
    myTable.Range.Copy
    
    Dim salesChart As Chart
    Dim chartWorkSheet As Excel.Worksheet
    Dim x As Integer
    Dim RowCount As Integer
    Dim ColumnCount As Integer
    Dim LastColumn As String

    Set salesChart = ActiveDocument.Shapes.AddChart.Chart
    salesChart.ChartType = xlPie
    salesChart.HasTitle = True
    salesChart.ChartTitle.Text = "by Severity"
    Set chartWorkSheet = salesChart.ChartData.Workbook.Worksheets(1)
    
    RowCount = myTable.Rows.Count
    ColumnCount = myTable.Columns.Count
    
    If ColumnCount < 26 Then
        LastColumn = Chr(64 + ColumnCount)
    Else
        LastColumn = Chr(Int(ColumnCount / 26) + 64) & Chr((ColumnCount Mod 26) + 64)
    End If
    
    With chartWorkSheet
        .ListObjects("Table1").DataBodyRange.Delete
        .ListObjects("Table1").Resize chartWorkSheet.Range("A1:" & LastColumn & RowCount)
        .Range("A1:" & LastColumn & RowCount).Select
        .Paste
    End With
    salesChart.HasLegend = True
    
    salesChart.SeriesCollection(1).Points(1).Interior.Color = RGB(&H5E, &HB7, &H0)
    salesChart.SeriesCollection(1).Points(2).Interior.Color = RGB(&HFF, &HE4, &H0)
    salesChart.SeriesCollection(1).Points(3).Interior.Color = RGB(&HFF, &HBA, &H0)
    salesChart.SeriesCollection(1).Points(4).Interior.Color = RGB(&HED, &H0, &H0)
    salesChart.SeriesCollection(1).Points(5).Interior.Color = RGB(&H0, &H0, &H0)
    salesChart.Parent.width = 240
    salesChart.Parent.Height = 220
    salesChart.ChartData.Workbook.Close
    
    Dim InSHP As InlineShape
    Set InSHP = salesChart.Parent.ConvertToInlineShape
    InSHP.Range.Cut
    
    myTable.Select
    Selection.Collapse wdCollapseEnd
    Selection.Paste
    
    
End Sub


Public Sub createComponentStackedBarChart()

    Dim myTable
    Set myTable = Selection.Tables.Item(1)
    
    myTable.Select
    Selection.Collapse wdCollapseEnd
    Selection.MoveUp wdLine, 1, wdMove
    Selection.SelectCell
    Selection.Rows.Delete

    myTable.Select
    myTable.Range.Copy
    
    Dim salesChart As Chart
    Dim chartWorkSheet As Excel.Worksheet
    Dim x As Integer
    Dim RowCount As Integer
    Dim ColumnCount As Integer
    Dim LastColumn As String

    Set salesChart = ActiveDocument.Shapes.AddChart.Chart
    salesChart.ChartType = xlColumnStacked
    salesChart.HasTitle = True
    salesChart.ChartTitle.Text = "by Component"
    salesChart.HasLegend = False
    salesChart.Axes(xlCategory).TickLabels.Orientation = 45 ' degrees
    salesChart.Axes(xlCategory).TickLabelSpacing = 1
    salesChart.Parent.width = 600
    salesChart.Parent.Height = 600
    
    Set chartWorkSheet = salesChart.ChartData.Workbook.Worksheets(1)
    
    RowCount = myTable.Rows.Count
    ColumnCount = myTable.Columns.Count
    
    If ColumnCount < 26 Then
        LastColumn = Chr(64 + ColumnCount)
    Else
        LastColumn = Chr(Int(ColumnCount / 26) + 64) & Chr((ColumnCount Mod 26) + 64)
    End If
    
    With chartWorkSheet
        .ListObjects("Table1").DataBodyRange.Delete
        .ListObjects("Table1").Resize chartWorkSheet.Range("A1:" & LastColumn & RowCount)
        .Range("A1:" & LastColumn & RowCount).Select
        .Paste
    End With
    
    
    Dim i As Integer
    For i = 1 To RowCount - 1
        salesChart.SeriesCollection(1).Points(i).Interior.Color = RGB(&HFF, &HE4, &H0)
        salesChart.SeriesCollection(2).Points(i).Interior.Color = RGB(&HFF, &HBA, &H0)
        salesChart.SeriesCollection(3).Points(i).Interior.Color = RGB(&HED, &H0, &H0)
        salesChart.SeriesCollection(4).Points(i).Interior.Color = RGB(&H0, &H0, &H0)
    Next
    
    salesChart.Parent.width = 240
    salesChart.Parent.Height = 220
    salesChart.ChartData.Workbook.Close
    
    Dim InSHP As InlineShape
    Set InSHP = salesChart.Parent.ConvertToInlineShape
    InSHP.Range.Cut
    
    myTable.Select
    Selection.Collapse wdCollapseEnd
    Selection.Paste
    
    
End Sub