Excel Macro working with Outlook

[David]

I am trying to send a table from Excel within the body of an Outlook
(lastest versions) to be sent as a fax. Am able to do this, BUT when
the document prints out on the fax machine the formating is off (too
big for the sheet). I am flexible on changing the method I send it to
the fax machine, however it must be sent to the fax via macro. Below
is the code I am using.

Any help would be greatly appreciated.

David

Public Sub DoIt()
'On Error GoTo Handler
Dim EmailAddress(0 To 2) As String
Dim Count As Integer
Dim N As Integer
Dim sRec1(0) As String
Dim sRec2(0 To 1) As String
Dim sRec3(0 To 2) As String

Count = 0

'If Range Email Address1 countains a valid email address then
assign it to a slot in the EmailAddress array
If Len(Range("EmailAddress1").Value) > 2 Then
EmailAddress(Count) = Range("EmailAddress1").Value
Count = Count + 1
End If

'If Range Email Address2 countains a valid email address then
assign it to a slot in the EmailAddress array
If Len(Range("EmailAddress2").Value) > 2 Then
EmailAddress(Count) = Range("EmailAddress2").Value
Count = Count + 1
End If

'If Range Email Address3 countains a valid email address then
assign it to a slot in the EmailAddress array
If Len(Range("EmailAddress3").Value) > 2 Then
EmailAddress(Count) = Range("EmailAddress3").Value
Count = Count + 1
End If

If Count = 0 Then
MsgBox "There were no valid email addresses or fax numbers,
please send manually."
Application.Quit
End If


If Count = 1 Then
sRec1(0) = EmailAddress(0)
EmailActiveSheetInBody sRec1, "Order Confirmation - Test"
End If

If Count = 2 Then
sRec2(0) = EmailAddress(0)
sRec2(1) = EmailAddress(1)
EmailActiveSheetInBody sRec2, "Order Confirmation - Test"
End If

If Count = 3 Then
sRec3(0) = EmailAddress(0)
sRec3(1) = EmailAddress(1)
sRec3(2) = EmailAddress(2)

EmailActiveSheetInBody sRec3, "Order Confirmation - Test"
End If




Exit Sub
Handler:
MsgBox "An error has occured, email and or fax confirmations have not
been sent. Please check email addresses and/or fax numbers."
Application.Quit

End Sub



Public Sub EmailActiveSheetInBody(rasRecipients() As String, _
rsSubject As String)

On Error GoTo Handler
SendHTMLEmail rasRecipients, rsSubject, sGetActiveSheetHTML

Exit Sub
Handler:
MsgBox "An error has occured, email and or fax confirmations have not
been sent. Please check email addresses and/or fax numbers."
Application.Quit

End Sub

Private Function sGetActiveSheetHTML() As String

Dim sFullName As String
Dim fso As Scripting.FileSystemObject
Dim fsoTS As Scripting.TextStream

Application.ScreenUpdating = False
sFullName = Environ$("temp") & Application.PathSeparator _
& Format$(Now(), "yymmddhhmmss") & _
Str(Timer * 100)
ActiveSheet.Copy
With ActiveWorkbook
.Sheets(1).SaveAs sFullName & ".htm", xlHtml
.Close False
End With

Set fso = New Scripting.FileSystemObject
Set fsoTS = fso.GetFile(sFullName & _
".htm").OpenAsTextStream(ForReading, TristateUseDefault)
sGetActiveSheetHTML = fsoTS.ReadAll
fsoTS.Close
Set fsoTS = Nothing
Set fso = Nothing
Kill sFullName & ".htm"
Application.ScreenUpdating = True


End Function

Private Sub SendHTMLEmail(rasRecipients() As String, _
rsSubject As String, rsHTMLBody As String)

Dim olApp As Outlook.Application
Dim olMI As Outlook.MailItem
Dim nRecip As Integer

Set olApp = GetObject("", "Outlook.Application")
Set olMI = olApp.GetNamespace("MAPI").GetDefaultFolder( _
olFolderInbox).Items.Add
With olMI
For nRecip = LBound(rasRecipients) To UBound(rasRecipients)
.Recipients.Add rasRecipients(nRecip)
Next nRecip
.Subject = rsSubject
.HTMLBody = rsHTMLBody
.Send
On Error Resume Next
Do Until olApp.GetNamespace("MAPI").GetDefaultFolder( _
olFolderOutbox).Items.Count = 0
DoEvents
Loop
On Error GoTo 0
End With
Set olMI = Nothing
Set olApp = Nothing

End Sub

 

[Dick Kusleika]

David

The only thing I can think of here is to reduce everything in Excel before
you save it as html. I don't know how complicated the format of your sheet
is, but I was thinking something like this

Activesheet.UsedRange.Cells.Font.Size =
ActiveSheet.UsedRange.Cells.Font.Size - 2

Then maybe loop through the columns in the usedrange and reduce the column
widths by a certain amount.

It's not foolproof, but it may work for you.