I am getting error at this line : FileName = Sheets(List1).Text '& " - " & ActiveWorkbook.name
For each selected worksheet, create a temporary workbook with the file name ?<worksheet name>.xls
i have created workbook but how will i keep the sheet in that folder.I am just displaying the name of the folder
Private Sub cmdsend_Click()
If txtFileLocation.Text = "" Then
MsgBox "Please select a workbook.", vbOKOnly, "RightAnswers"
cmdbrowsebook.SetFocus
ElseIf List1.Text = "" Then
MsgBox "Please select a worksheet.", vbOKOnly, "RightAnswers"
ElseIf Txtname.Text = "" Then
MsgBox "Please select an email recipient.", vbOKOnly, "RightAnswers"
ElseIf txtsubject.Text = "" Then
MsgBox "Please enter an email subject."
Else
If MsgBox("The <number of selected worksheets> Excel worksheets will be sent to the <number of selected email recipients> selected email address(es). Would you like to continue?", vbYesNo, "RightAnswers") = vbNo Then
MsgBox ("The selected worksheets will not be emailed to the selected recipients.")
End If
Dim Num As Long
Dim MaxNum As Long
Dim MinNum As Long
Dim Path As String
MinNum = 1
MaxNum = 1000
Path = folderpath & "RightAnswersTempWorkbooks"
On Error Resume Next
MkDir Path
Err.Clear
Randomize
Do
Num = Int((MaxNum - MinNum + 1) * Rnd + MinNum)
MkDir Path & "\RightAnswersTempWorkbooks" & Num
If Err = 0 Then
Exit Do
Else
Err.Clear
End If
Loop
On Error GoTo 0
MsgBox "Folder Created: " & Path & "\RightAnswersTempWorkbooks" & Num
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Dim FileName As String
Dim y As Long
Dim TempChar As String
Dim SaveName As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
FileName = Sheets(List1).Text '& " - " & ActiveWorkbook.name
For y = 1 To Len(FileName)
TempChar = Mid(FileName, y, 1)
Select Case TempChar
Case Is = "/", "\", "*", "?", """", "<", ">", "|", ":"
Case Else
SaveName = SaveName & TempChar
End Select
Next y
Sheets(List1).Text.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs SaveName
Wb.ChangeFileAccess xlReadOnly
With EmailItem
.Subject = txtsubject
.Body = txtbody
.To = txtpersons
.Attachments.Add Wb.FullName
.Send
End With
Kill Wb.FullName
Wb.Close False
Application.ScreenUpdating = True
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End If
End Sub
Reply With Quote
Originally Posted by v_gyku
