Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Excel Macro working with Outlook
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Excel Macro working with Outlook
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. -- Dick Kusleika MVP - Excel www.dicks-clicks.com Post all replies to the newsgroup. "David" wrote in message om... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macro to Paste Excel into Outlook | Excel Discussion (Misc queries) | |||
Excel working in with Outlook | New Users to Excel | |||
Macro to email Excel workbook through MS Outlook | Excel Discussion (Misc queries) | |||
Excel to Outlook Calendar Macro | Excel Discussion (Misc queries) | |||
Getting rid of Outlook warnings from excel macro | Excel Programming |