Pictures in email attachment not working

[smj43]

Hi all, first post here but could really do with some help!

I've got a code which I'm using as part of a form which will allow the user to click a command button to insert pictures into another sheet. I've then got another command button which will send the completed form together with the 2nd worksheet containing the pictures. Everything works great however there are 2 issues:

1. When the pictures are inserted into the 'Pictures' worksheet, they stack on top of each other. Is there anyway to get the pictures to be inserted separately (i.e. one below the other)?
2. When opening the email attachment, the pictures do not show. Instead I get 'The linked picture cannot be displayed' error message. Why is this?

Here is the code I'm using...

Private Sub CommandButton1_Click()

Dim oApp As Object
   Dim oMail As Object
   Dim LWorkbook As Workbook
   Dim LFileName As String


   'Turn off screen updating
   Application.ScreenUpdating = False


   'Copy the active worksheet and save to a temporary workbook
   Sheets(Array("Form", "Pictures")).Copy
   Set LWorkbook = ActiveWorkbook


   'Create a temporary file in your current directory that uses the name
   ' of the sheet as the filename
   LFileName = Range("C5") & " New Store Request.xlsx"
   On Error Resume Next
   'Delete the file if it already exists
   Kill LFileName
   On Error GoTo 0
   'Save temporary file
   Application.DisplayAlerts = False
   LWorkbook.SaveAs Filename:=LFileName


   'Create an Outlook object and new mail message
   Set oApp = CreateObject("Outlook.Application")
   Set oMail = oApp.CreateItem(0)


   'Set mail attributes (uncomment lines to enter attributes)
   ' In this example, only the attachment is being added to the mail message
   With oMail
      .To = "email@email.com"
      .Subject = Range("C5") & " New Store Request Form"
      .body = "Hello," & vbCrLf & vbCrLf & _
      "Please find attached completed New Store Request Form" & vbCrLf & vbCrLf & _
      "Kind Regards"
      .Attachments.Add LWorkbook.FullName
      '.Display  'Comment out this line and uncomment the next line when ready to auto-send email
      .Send    'Uncomment this line and comment out the line above when ready to auto-send email
   End With


   'Delete the temporary file and close temporary Workbook
   LWorkbook.ChangeFileAccess Mode:=xlReadOnly
   Kill LWorkbook.FullName
   LWorkbook.Close SaveChanges:=False


   'Turn back on screen updating
   Application.ScreenUpdating = True
   Set oMail = Nothing
   Set oApp = Nothing
   
   MsgBox "Your request has been succesfully submitted"

End Sub

Private Sub CommandButton2_Click()
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngDest As Range
    strFileName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
    If strFileName = "False" Then Exit Sub
    Set rngDest = Worksheets("Pictures").Range("A1:M27")
    Set objPic = Worksheets("Pictures").Pictures.Insert(strFileName)
    With objPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = rngDest.Left
        .Top = rngDest.Top
        .Width = rngDest.Width
        .Height = rngDest.Height
    End With
    MsgBox "Your picture has been added"
End Sub

Hopefully this makes sense. I'm not at all clued up on this so if anyone can help in the most dumbed down terms, it would be much appreciated!

 

[smj43]

I was able to 'fix' point number 2 by changing the code from .Pictures.Insert to .Shapes.AddPictures. The code works (as in does what it should) and can now see pictures in the email attachment however the code is bugging 'Run Time Error 13 Type Mismatch'. What have I done wrong?

Private Sub CommandButton2_Click()
    Dim strFileName As String
    Dim objPic As Picture
    strFileName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
    If strFileName = "False" Then Exit Sub
    Set objPic = Worksheets("Pictures").Shapes.AddPicture(Filename:=(strFileName), linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=0, Top:=0, Width:=300, Height:=300)
    MsgBox "Your picture has been added"
End Sub

 

[smj43]

Don't worry, found the error. It is working fine now

Just need some help with my 1st point please....

1. When the pictures are inserted into the 'Pictures' worksheet, they stack on top of each other. Is there anyway to get the pictures to be inserted separately (i.e. one below the other)?

Here is current code...

Private Sub CommandButton1_Click()

Dim oApp As Object
   Dim oMail As Object
   Dim LWorkbook As Workbook
   Dim LFileName As String


   'Turn off screen updating
   Application.ScreenUpdating = False


   'Copy the active worksheet and save to a temporary workbook
   Sheets(Array("Form", "Pictures")).Copy
   Set LWorkbook = ActiveWorkbook


   'Create a temporary file in your current directory that uses the name
   ' of the sheet as the filename
   LFileName = Range("C5") & " New Store Request.xlsx"
   On Error Resume Next
   'Delete the file if it already exists
   Kill LFileName
   On Error GoTo 0
   'Save temporary file
   Application.DisplayAlerts = False
   LWorkbook.SaveAs Filename:=LFileName


   'Create an Outlook object and new mail message
   Set oApp = CreateObject("Outlook.Application")
   Set oMail = oApp.CreateItem(0)


   'Set mail attributes (uncomment lines to enter attributes)
   ' In this example, only the attachment is being added to the mail message
   With oMail
      .To = "email@email.com"
      .Subject = Range("C5") & " New Store Request Form"
      .body = "Hello," & vbCrLf & vbCrLf & _
      "Please find attached completed New Store Request Form" & vbCrLf & vbCrLf & _
      "Kind Regards"
      .Attachments.Add LWorkbook.FullName
      '.Display  'Comment out this line and uncomment the next line when ready to auto-send email
      .Send    'Uncomment this line and comment out the line above when ready to auto-send email
   End With


   'Delete the temporary file and close temporary Workbook
   LWorkbook.ChangeFileAccess Mode:=xlReadOnly
   Kill LWorkbook.FullName
   LWorkbook.Close SaveChanges:=False


   'Turn back on screen updating
   Application.ScreenUpdating = True
   Set oMail = Nothing
   Set oApp = Nothing
   
   MsgBox "Your request has been succesfully submitted"

End Sub

Private Sub CommandButton2_Click()
    Dim strFileName As String
    Dim objPic As Object
    strFileName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
    If strFileName = "False" Then Exit Sub
    Set objPic = Worksheets("Pictures").Shapes.AddPicture(Filename:=(strFileName), linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=0, Top:=0, Width:=300, Height:=300)
    MsgBox "Your picture has been added"
End Sub