DoctorV3774
Programmer
I have an application used by 55 users. In the final step they are asked to e-mail the sheet they are on to an individual. What happens during the execution of this code is that it sends one sheet of just values to a user, stripping away all named ranges except the Print rane and removing all VBA. Everything works fine except that during the copy worksheet it truncates any merged cell with over 255 characters. The whole sub works ggreat except for this one critical area. It kills the file after the e-mail dow=es great stuff BUT I HAVE TO SOLVE THIS TRUNCATION. If I merely highlight the wholw sheet and copy it to a new sheet it takes all the data but of course then it loses the formatting. I need to do something like that but maintain the formatting. Please help this is an urgent problem. Thanks Code below
************************************
'You must add a reference to the Microsoft outlook Library
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Do you want to E-Mail this Quote Letter?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Warning" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
' context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
On Error GoTo err_showSendDialog
If Response = vbYes Then ' User chose Yes.
Application.ScreenUpdating = False
'Dim OutApp As Outlook.Application
'Dim OutMail As Outlook.MailItem
Dim wb As Workbook
Dim strdate As String
Dim Sub_ID As String
Sub_ID = ActiveSheet.Range("a6").Value
strdate = Format(Now, "Medium Date")
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
With ActiveSheet.Copy
With ActiveSheet.Cells
.Copy
.PasteSpecial xlValues
End With
End With
Application.Run ("FinalShortCleanup")
Set wb = ActiveWorkbook
'Code to remove all Named Ranges and VBA upon creation of Final Short Quote
With wb
.ActiveSheet.Shapes("CommandButton1").Delete
.ActiveSheet.Shapes("CommandButton2").Delete
.ActiveSheet.Shapes("CommandButton3").Delete
.ActiveSheet.Shapes("CommandButton4").Delete
.ActiveSheet.Shapes("cmdSendBut").Delete
Call Del(Application.Workbooks(ActiveWorkbook.Name))
Call DeleteAllVBA
.SaveAs "EMailSubmission_" & Sub_ID & "_" & strdate & ".xls"
Application.MailLogon ("AFGDefault")
Application.Dialogs(xlDialogSendMail).Show .ActiveSheet.Range("b12").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
'Set OutMail = Nothing
'Set OutApp = Nothing
'Set OutApp = Nothing
SetFocus FindWindow(vbNullString, Application.Caption)
Sheets("Quote_Info").Select
Range("j2").Activate
Else ' User chose No.
DoCmd.CancelEvent
End If
exit_showSendDialog:
Exit Sub
err_showSendDialog:
If Err.Number = 2501 Then 'User Cancelled DoCmd
Resume exit_showSendDialog
Else 'Add your own error handling routine here
Resume exit_showSendDialog
Resume Next
End If
*********************************************
************************************
'You must add a reference to the Microsoft outlook Library
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Do you want to E-Mail this Quote Letter?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Warning" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
' context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
On Error GoTo err_showSendDialog
If Response = vbYes Then ' User chose Yes.
Application.ScreenUpdating = False
'Dim OutApp As Outlook.Application
'Dim OutMail As Outlook.MailItem
Dim wb As Workbook
Dim strdate As String
Dim Sub_ID As String
Sub_ID = ActiveSheet.Range("a6").Value
strdate = Format(Now, "Medium Date")
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
With ActiveSheet.Copy
With ActiveSheet.Cells
.Copy
.PasteSpecial xlValues
End With
End With
Application.Run ("FinalShortCleanup")
Set wb = ActiveWorkbook
'Code to remove all Named Ranges and VBA upon creation of Final Short Quote
With wb
.ActiveSheet.Shapes("CommandButton1").Delete
.ActiveSheet.Shapes("CommandButton2").Delete
.ActiveSheet.Shapes("CommandButton3").Delete
.ActiveSheet.Shapes("CommandButton4").Delete
.ActiveSheet.Shapes("cmdSendBut").Delete
Call Del(Application.Workbooks(ActiveWorkbook.Name))
Call DeleteAllVBA
.SaveAs "EMailSubmission_" & Sub_ID & "_" & strdate & ".xls"
Application.MailLogon ("AFGDefault")
Application.Dialogs(xlDialogSendMail).Show .ActiveSheet.Range("b12").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
'Set OutMail = Nothing
'Set OutApp = Nothing
'Set OutApp = Nothing
SetFocus FindWindow(vbNullString, Application.Caption)
Sheets("Quote_Info").Select
Range("j2").Activate
Else ' User chose No.
DoCmd.CancelEvent
End If
exit_showSendDialog:
Exit Sub
err_showSendDialog:
If Err.Number = 2501 Then 'User Cancelled DoCmd
Resume exit_showSendDialog
Else 'Add your own error handling routine here
Resume exit_showSendDialog
Resume Next
End If
*********************************************