I have pieced together some code using excel as a file picker to add images to embed within subject body.
Everything is working just fine with basic alignment, but I would like to get some help adding these images into a table with a specific formatting
Outlook seems not to have a huge support for VBA
"Side quest" One bug is not too bad but is that you have pop out window in order for it to work.
I do have it coded in that way but would be cool to have it code to run the macro to pop it out for you.
Here is some code that I use in my word document that I looking to smash into the code above
Any help would be appreciated
Everything is working just fine with basic alignment, but I would like to get some help adding these images into a table with a specific formatting
Outlook seems not to have a huge support for VBA
"Side quest" One bug is not too bad but is that you have pop out window in order for it to work.
I do have it coded in that way but would be cool to have it code to run the macro to pop it out for you.
VBA Code:
#If VBA7 Then
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal class As String, ByVal caption As String) As LongPtr
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal win As LongPtr) As LongPtr
#End If
Option Explicit
Sub ShowDialogBox()
Dim fd As Office.FileDialog
Dim xlApp As Excel.Application
Dim hxl As LongPtr
Dim vrtSelectedItem As Variant
Dim i As Long
Set xlApp = New Excel.Application
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
hxl = FindWindowA("XLMAIN", "EXCEL")
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If Not IsNull(hxl) Then
SetForegroundWindow (hxl)
End If
If fd.Show = -1 Then
For Each vrtSelectedItem In fd.SelectedItems
i = i + 1
'Put your code here
Dim objShell As Object
Dim objLocalFolder As Object
Dim strLocalFolder As String
Dim strFile As String
Dim objFileSystem As Object
Dim strEmbedImage As String
Dim objMail As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objAttachment As Outlook.Attachment
Dim objMailDocument As Word.Document
Dim objInlineShape As Word.InlineShape
Dim objDocSelection As Word.Selection
Set objMail = Outlook.Application.ActiveInspector.CurrentItem
Set objAttachments = objMail.Attachments
Dim strPath As String
strPath = vrtSelectedItem
strFile = Right(strPath, Len(strPath) - InStrRev(strPath, "\"))
objAttachments.Add vrtSelectedItem
Set objAttachment = objAttachments.Add(vrtSelectedItem)
objAttachment.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x3712001E", "item" & i
objMail.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8514000B", True
strEmbedImage = "<br /><img src=cid:item" & i & " align=middle width='450'/>" & strEmbedImage
objMail.HTMLBody = "<HTML>" & "<BODY>" & strEmbedImage & "</BODY></HTML>"
Dim item
If TypeName(item) = "MailItem" Then
Set objMail = item
End If
If Not (objMail Is Nothing) Then
Set objMailDocument = objMail.GetInspector.WordEditor
Dim soup As Variant
For Each objInlineShape In objMailDocument.InlineShapes
objInlineShape.Select
Set objDocSelection = objMailDocument.Application.Selection
Set soup = objDocSelection.ParagraphFormat
With soup
.Alignment = wdAlignParagraphCenter
.KeepWithNext = True
.SpaceAfter = 0
.SpaceBefore = 0
End With
Next
End If
Next vrtSelectedItem
Else
MsgBox "User hit cancel"
Exit Sub
'Do something different here
End If
End With
End SubHere is some code that I use in my word document that I looking to smash into the code above
VBA Code:
Sub AddPics()
Application.ScreenUpdating = False
Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single, Range
On Error GoTo ErrExit
NumCols = 1
RwHght = CentimetersToPoints(9)
On Error GoTo 0
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
'Create a paragraph Style with 0 space before/after & centre-aligned
On Error Resume Next
With ActiveDocument
.Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
On Error GoTo 0
With .Styles("TblPic").ParagraphFormat
.Alignment = wdAlignParagraphCenter
.KeepWithNext = True
.SpaceAfter = 0
.SpaceBefore = 0
End With
End With
'Add a 2-row by NumCols-column table to take the images
Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
With ActiveDocument.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
ColWdth = TblWdth / NumCols
End With
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 8
.Columns.Width = ColWdth
.Borders.Enable = False
End With
Dim s As Variant
s = InputBox("What process?", "Enter stage of Rebuild", "Type Here")
ActiveDocument.TextBox1.Value = s
CaptionLabels.Add Name:=ActiveDocument.TextBox1.Value
For i = 1 To .SelectedItems.Count Step NumCols
r = ((i - 1) / NumCols + 1) * 2 - 1
'Format the rows
Call FormatRows(oTbl, r, RwHght)
For c = 1 To NumCols
j = j + 1
'Insert the Picture
Set iShp = ActiveDocument.InlineShapes.AddPicture( _
Filename:=.SelectedItems(j), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
With iShp
.LockAspectRatio = True
If (.Width < ColWdth) And (.Height < RwHght) Then
.Width = ColWdth
If .Height > RwHght Then .Height = RwHght
End If
End With
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
StrTxt = " Location: " & "Description: "
'Insert the Caption on the row below the picture
With oTbl.Cell(r + 1, c).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:=ActiveDocument.TextBox1.Value, Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
.Font.Size = 12
.Font.Bold = True
.Font.Italic = False
.Font.Name = "Calibri (Body)"
End With
'Exit when we're done
If j = .SelectedItems.Count Then Exit For
Next
'Add extra rows as needed
If j < .SelectedItems.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
End If
Next
Else
End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
Sub FormatRows(oTbl As table, x As Long, Hght As Single)
With oTbl
With .Rows(x)
.Height = Hght
.HeightRule = wdRowHeightExactly
.Range.Style = "TblPic"
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(1.25)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End SubAny help would be appreciated
