Saving a single work***

I am trying to ise a command button to save a single work*** from a
workbook to export to outlook and mail it. So far I have the following which
works fine but mails the whole workbook. My code is not good so details are
appreciated.
Private Sub CommandButton1_Click()
'
'' Email ***
' Taken from Dustin's time*** macro
' 1/28/08
'

Dim Fname
Fname = Active***.Name

Range("A1:N41").Select
Selection.Copy
'Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ActiveWindow.DisplayGridlines = False 'added
Application.CutCopyMode = False 'added
Application.StandardFont = "Tahoma"
Application.StandardFontSize = "10"
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Active***.Paste
With Active***.PageSetup
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.25)
End With
ChDir "C:\"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\SHD_current_week.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.DisplayAlerts = True
Application.Dialogs(xlDialogSendMail).Show
End Sub


.