Combine two vba codes

QuestionEdit

QUESTION: Sorry I don't expect you to get back straightaway it is Saturday after all. : -)

Well, here's my question.

I copied two bits of code from somewhere which work great, one sends a sheet from a work book and one sends a selection as body from a different sheet in the same workbook. It bugs me that I can't work out how to combine the two also at the moment I save a dated sheet and at the end delete the original but this results in the sent temp file having two file extensions. Because I don't really understand this complicated 'Dim' code bits I'm a bit stumped about the best way around it

Thanks in advance. Here's the code.

Sub mailbanking1()

' Don't forget to copy the function RangetoHTML in the module. ' Working in Office 2000-2007

  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object

  Set rng = Nothing
  On Error Resume Next
  'Only the visible cells in the selection
  Set rng = Selection.SpecialCells(xlCellTypeVisible)
  'You can also use a range if you want
  Set rng = Sheets("MAILING").Range("A1:H10").SpecialCells(xlCellTypeVisible)
  On Error GoTo 0

  If rng Is Nothing Then
      MsgBox "The selection is not a range or the sheet is protected" & _
             vbNewLine & "please correct and try again.", vbOKOnly
      Exit Sub
  End If

  With Application
      .EnableEvents = False
      .ScreenUpdating = False
  End With

  Set OutApp = CreateObject("Outlook.Application")
  OutApp.Session.Logon
  Set OutMail = OutApp.CreateItem(0)

  On Error Resume Next
  With OutMail
      .To = "jim"
      .CC = ""
      .BCC = ""
      .Subject = "banking summary - " & Range("g3")
      .HTMLBody = RangetoHTML(rng)
      .Display
  End With
  On Error GoTo 0

  With Application
      .EnableEvents = True
      .ScreenUpdating = True
  End With

  Set OutMail = Nothing
  Set OutApp = Nothing

End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2007

  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook

  TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy") & ".htm"

  'Copy the range and create a new workbook to past the data in
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
      .Cells(1).PasteSpecial Paste:=8
      .Cells(1).PasteSpecial xlPasteValues, , False, False
      .Cells(1).PasteSpecial xlPasteFormats, , False, False
      .Cells(1).Select
      Application.CutCopyMode = False
      On Error Resume Next

      .DrawingObjects.Delete
      On Error GoTo 0
  End With

  'Publish the sheet to a htm file
  With TempWB.PublishObjects.Add( _
       SourceType:=xlSourceRange, _
       Filename:=TempFile, _
       Sheet:=TempWB.Sheets(1).Name, _
       Source:=TempWB.Sheets(1).UsedRange.Address, _
       HtmlType:=xlHtmlStatic)
      .Publish (True)
  End With

  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.ReadAll
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                        "align=left x:publishsource=")

  'Close TempWB
  TempWB.Close SaveChanges:=False

  'Delete the htm file we used in this function
  Kill TempFile

  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing

End Function

__________________________________________________

'second bit of code to send file

___________________________________________________

Sub sendtoHO() Sheets("MAILING").Select

  MyFileName = "\\Conran-mb\files\JIM\JIM2009\Cash Office\BANKING SHEETS\Banking Sheet " & Range("h5") & ".xls"
  ActiveWorkbook.SaveAs Filename:=MyFileName

'Working in 2000-2007

  Dim FileExtStr As String
  Dim FileFormatNum As Long
  Dim Sourcewb As Workbook
  Dim Destwb As Workbook
  Dim TempFilePath As String
  Dim TempFileName As String
  Dim OutApp As Object
  Dim OutMail As Object

  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With

  Set Sourcewb = ActiveWorkbook

  'Copy the sheet to a new workbook
  Sheets("Weekly Banking Report").Select

  ActiveSheet.DrawingObjects.Select
  Selection.Cut
  ActiveSheet.Copy
  Set Destwb = ActiveWorkbook

  'Determine theversion and file extension/format
  With Destwb
      If Val(Application.Version) < 12 Then
          'You use2000-2003
          FileExtStr = ".xls": FileFormatNum = -4143
      Else
          'You use2007, we exit the sub when your answer is
          'NO in the security dialog that you only see  when you copy
          'a sheet from a xlsm file with macro's disabled.
          If Sourcewb.Name = .Name Then
              With Application
                  .ScreenUpdating = True
                  .EnableEvents = True
              End With
              MsgBox "Your answer is NO in the security dialog"
              Exit Sub
          Else
              Select Case Sourcewb.FileFormat
              Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
              Case 52:
                  If .HasVBProject Then
                      FileExtStr = ".xlsm": FileFormatNum = 52
                  Else
                      FileExtStr = ".xlsx": FileFormatNum = 51
                  End If
              Case 56: FileExtStr = ".xls": FileFormatNum = 56
              Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
              End Select
          End If
      End If
  End With

  '    'Change all cells in the worksheet to values if you want
      With Destwb.Sheets(1).UsedRange
          .Cells.Copy
          .Cells.PasteSpecial xlPasteValues
          .Cells(1).Select
      End With
      Application.CutCopyMode = False

  'Save the new workbook/Mail it/Delete it
  TempFilePath = Environ$("temp") & "\"
  TempFileName = Sourcewb.Name

  Set OutApp = CreateObject("Outlook.Application")
  OutApp.Session.Logon
  Set OutMail = OutApp.CreateItem(0)

  With Destwb
      .SaveAs TempFilePath & TempFileName & FileExtStr, _
              FileFormat:=FileFormatNum
      On Error Resume Next
      With OutMail
          .To = "hpalao"
          .CC = "Barbour, Isabelle; Rivett, Nick"
          .BCC = ""
          .Subject = "Banking Sheet P" & Range("G3") & "W" & Range("I3")
          .Body = ""
          .Attachments.Add Destwb.FullName
          'You can add other files also like this
          '.Attachments.Add ("C:\test.txt")
          .Display
      End With
      On Error GoTo 0
      .Close SaveChanges:=False
  End With

  'Delete the file you have send
  Kill TempFilePath & TempFileName & FileExtStr

  Set OutMail = Nothing
  Set OutApp = Nothing

Dim Answer As String Dim MyNote As String

  'Place your text here
  MyNote = "Delete the temporary Banking Sheet? It has been saved already as Banking Sheet 'last weeks date'"

  'Display MessageBox
  Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "Do you want to delete the 'Banking Sheet'?")

  If Answer = vbNo Then
      'Code for No button Press
      MsgBox "The Banking Sheet is still there and a This one for this week has been saved"
  Else
       With Application
      .ScreenUpdating = True
      .EnableEvents = True

      Kill "\\Conran-mb\files\JIM\JIM2009\Cash Office\BANKING SHEETS\Banking Sheet.xls"

  End With
      MsgBox "The Banking Sheet has been deleted but a new one has been saved for last week"
  End If

End Sub _____________________________________

Thanks again

ANSWER: So, what is it that you want to know? How to combine the two so that you only have to run one macro and not two?

---------- FOLLOW-UP ----------

QUESTION: Yes. Sorry if my attempt to be polite made my question unclear. Also as a bonus if you could explain how to stop the sent file having two extension that would be great.

AnswerEdit

The easiest way to combine the two is to write a third routine that calls each one, like:

Sub RunBoth()

 Call mailbanking1
 Call sendtoHO

End Sub

and then just run RunBoth. I suggest you contact the person who wrote these rountines for you to explain how they work and to make any modifications.