Adding to VB functions together

[themightyreds]

Hi all,

I am useless at VB but through the use of all your archived wisdom I have been able to not only create myself a userform but have also been able to them turn the saved data into an email. SO Thanks already!

I have two VB scripts (is that the right term?) which I need to join together. The first is the basic script for saving the data before unloading - this is runs from a click on a control button on the form. The second is a script for placing the body of a worksheet into an e-mail which currently runs from a button on the worksheet. I wish to join them both together so they both run off of the userform control button but don't know how to do so. Can anyone help please?


Excuse the look of the script my work pc won't let me download anything to improve the visuals

Private Sub cmdAdd_Click()
Dim iRow As Long
Dim WS As Worksheet
Set WS = Worksheets("Daily Interlines")

'find first empty row in database
iRow = WS.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row

'copy the data to the database
WS.Cells(iRow, 1).Value = Me.TxtPrefix.Value
WS.Cells(iRow, 2).Value = Me.TxtAWB.Value
WS.Cells(iRow, 3).Value = Me.TxtOrigin.Value
WS.Cells(iRow, 4).Value = Me.TxtDest.Value
WS.Cells(iRow, 5).Value = Me.TxtAWBpcs.Value
WS.Cells(iRow, 6).Value = Me.TxtAWBkgs.Value
WS.Cells(iRow, 8).Value = Me.TxtAWBDesc.Value
WS.Cells(iRow, 9).Value = Me.Txtpcs1.Value
WS.Cells(iRow, 10).Value = Me.Txtlgth1.Value
WS.Cells(iRow, 11).Value = Me.Txtwide1.Value
WS.Cells(iRow, 12).Value = Me.Txthigh1.Value
WS.Cells(iRow, 13).Value = Me.Txtpcs2.Value
WS.Cells(iRow, 14).Value = Me.Txtlgth2.Value
WS.Cells(iRow, 15).Value = Me.Txtwide2.Value
WS.Cells(iRow, 16).Value = Me.Txthigh2.Value
WS.Cells(iRow, 17).Value = Me.Txtpcs3.Value
WS.Cells(iRow, 18).Value = Me.Txtlgth3.Value
WS.Cells(iRow, 19).Value = Me.Txtwide3.Value
WS.Cells(iRow, 20).Value = Me.Txthigh3.Value
WS.Cells(iRow, 21).Value = Me.Txtpcs4.Value
WS.Cells(iRow, 22).Value = Me.Txtlgth4.Value
WS.Cells(iRow, 23).Value = Me.Txtwide4.Value
WS.Cells(iRow, 24).Value = Me.Txthigh4.Value
WS.Cells(iRow, 25).Value = Me.Txtpcs5.Value
WS.Cells(iRow, 26).Value = Me.Txtlgth5.Value
WS.Cells(iRow, 27).Value = Me.Txtwide5.Value
WS.Cells(iRow, 28).Value = Me.Txthigh5.Value
WS.Cells(iRow, 29).Value = Me.Txtpcs6.Value
WS.Cells(iRow, 30).Value = Me.Txtlgth6.Value
WS.Cells(iRow, 31).Value = Me.Txtwide6.Value
WS.Cells(iRow, 32).Value = Me.Txthigh6.Value
WS.Cells(iRow, 33).Value = Me.TxtCube.Value
WS.Cells(iRow, 35).Value = Me.TxtInflt.Value
WS.Cells(iRow, 36).Value = Me.TxtInarrive.Value
WS.Cells(iRow, 37).Value = Me.Txtintime.Value
WS.Cells(iRow, 40).Value = Me.ComboBoxCarrier.Value
WS.Cells(iRow, 41).Value = Me.TxtOnFlt1.Value
WS.Cells(iRow, 42).Value = Me.TxtOnDate1.Value
WS.Cells(iRow, 43).Value = Me.TxtOntimeDep1.Value
WS.Cells(iRow, 44).Value = Me.TxtOnArrive1.Value
WS.Cells(iRow, 45).Value = Me.TxtOnTimeArr1.Value
WS.Cells(iRow, 46).Value = Me.TxtOnFlt2.Value
WS.Cells(iRow, 47).Value = Me.TxtOnDate2.Value
WS.Cells(iRow, 48).Value = Me.TxtOntimeDep2.Value
WS.Cells(iRow, 49).Value = Me.TxtOnArrive2.Value
WS.Cells(iRow, 50).Value = Me.TxtOnTimeArr2.Value
WS.Cells(iRow, 69).Value = Me.TxtULD1.Value
WS.Cells(iRow, 70).Value = Me.TxtULDNos1.Value
WS.Cells(iRow, 71).Value = Me.TxtULDair1.Value
WS.Cells(iRow, 72).Value = Me.TxtULD2.Value
WS.Cells(iRow, 73).Value = Me.TxtULDNos2.Value
WS.Cells(iRow, 74).Value = Me.TxtULDair2.Value
WS.Cells(iRow, 75).Value = Me.TxtULD3.Value
WS.Cells(iRow, 76).Value = Me.TxtULDNos3.Value
WS.Cells(iRow, 77).Value = Me.TxtULDair3.Value
WS.Cells(iRow, 78).Value = Me.TxtULD4.Value
WS.Cells(iRow, 79).Value = Me.TxtULDNos4.Value
WS.Cells(iRow, 80).Value = Me.TxtULDair4.Value

'clear the data
Me.TxtPrefix.Value = ""
Me.TxtAWB.Value = ""
Me.TxtOrigin.Value = ""
Me.TxtDest.Value = ""
Me.TxtAWBpcs.Value = ""
Me.TxtAWBkgs.Value = ""
Me.TxtAWBDesc.Value = ""
Me.Txtpcs1.Value = ""
Me.Txtlgth1.Value = ""
Me.Txtwide1.Value = ""
Me.Txthigh1.Value = ""
Me.Txtpcs2.Value = ""
Me.Txtlgth2.Value = ""
Me.Txtwide2.Value = ""
Me.Txthigh2.Value = ""
Me.Txtpcs3.Value = ""
Me.Txtlgth3.Value = ""
Me.Txtwide3.Value = ""
Me.Txthigh3.Value = ""
Me.Txtpcs4.Value = ""
Me.Txtlgth4.Value = ""
Me.Txtwide4.Value = ""
Me.Txthigh4.Value = ""
Me.Txtpcs5.Value = ""
Me.Txtlgth5.Value = ""
Me.Txtwide5.Value = ""
Me.Txthigh5.Value = ""
Me.Txtpcs6.Value = ""
Me.Txtlgth6.Value = ""
Me.Txtwide6.Value = ""
Me.Txthigh6.Value = ""
Me.TxtCube.Value = ""
Me.TxtInflt.Value = ""
Me.TxtInarrive.Value = ""
Me.Txtintime.Value = ""
Me.ComboBoxCarrier.Value = ""
Me.TxtOnFlt1.Value = ""
Me.TxtOnDate1.Value = ""
Me.TxtOntimeDep1.Value = ""
Me.TxtOnArrive1.Value = ""
Me.TxtOnTimeArr1.Value = ""
Me.TxtOnFlt2.Value = ""
Me.TxtOnDate2.Value = ""
Me.TxtOntimeDep2.Value = ""
Me.TxtOnArrive2.Value = ""
Me.TxtOnTimeArr2.Value = ""
Me.TxtULD1.Value = ""
Me.TxtULDNos1.Value = ""
Me.TxtULDair1.Value = ""
Me.TxtULD2.Value = ""
Me.TxtULDNos2.Value = ""
Me.TxtULDair2.Value = ""
Me.TxtULD3.Value = ""
Me.TxtULDNos3.Value = ""
Me.TxtULDair3.Value = ""
Me.TxtULD4.Value = ""
Me.TxtULDNos4.Value = ""
Me.TxtULDair4.Value = ""

Me.TxtPrefix.SetFocus

Unload Me

End Sub


Email script



Function Mail_Selection_Range_Outlook_Body()
' 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 = Sheets("FFR MESSAGE").Range("A1:A6").SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").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 Function
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 = Sheets("FFR BUILD").Range("G8")
.CC = ""
.BCC = ""
.Subject = "FFR MESSAGE FROM LHRICBD"
.HTMLBody = StrBody & RangetoHTML(rng)
.DISPLAY 'or use .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Function
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 h-mm-ss") & ".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.Visible = True
.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 xublishsource=", _
"align=left xublishsource=")

'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

 

[John_w]

Call Mail_Selection_Range_Outlook_Body() from cmdAdd_Click() like this:

Mail_Selection_Range_Outlook_Body

Also, it doesn't need to be a Function.

 

[themightyreds]

Hi John,

I changed Function to Call but that errored - Oly comments may appear after End Sub

SO I removed the End Sub buit that errored saying Sub or Function not defined.

This is the joining ends, can you show me what they should be?

Me.TxtPrefix.SetFocus

Unload Me

End Sub

Call Mail_Selection_Range_Outlook_Body

 

[themightyreds]

bump

 

[John_w]

Call Mail_Selection_Range_Outlook_Body

must be somewhere inside Private Sub cmdAdd_Click() in order for it to be called from cmdAdd_Click. Call it in the logical place - you should know where this is.