Soru Belirtilen Sayfayı Mail Göndermek

[TURKOLOG]

Herkese Merhaba
Elimdeki aşağıda yazdığım kod çalışmakta ve sadece belirli bir sayfayı mail göndermektedir. Kod bu anlamda sorunsuz çalışmaktadır

Sub Mail_At()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("yetki").Select
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

'Aşağıdaki eklendi
Dim strBody As String, strSig As String
'

On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Application.ActivateMicrosoftApp (xlMicrosoftMail)
End If

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Şifre Hatırlatma"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "deneme@hotmail.com"
.CC = ""
.bcc = ""
.Subject = "Şifre Hatırlatma"
'.Body = "Saygılarımla" 'BUNU İPTAL ETTİM
.Attachments.Add Destwb.FullName
.Display

 .Recipients.ResolveAll
 
'Default İmza Eklendi
 strSig = .Htmlbody
 
'BODY YERİNE strBody kullan
 strBody = "<font face=Tahoma size=3> Saygılarımla </calibri> <p>" & _
 "<font color=green> Saygılarımla " & _
 "please visit: <mailto=deneme.gov.tr</a></font>"
 
 .Htmlbody = strBody & strSig


End With
On Error GoTo 0
.Close SaveChanges:=True
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Sheets("ANA SAYFA").Select
MsgBox "Mail gönderme işlemi tamamlanmıştır.", 64, "Bilgi_Mesajı"
End Sub

Kod bu haliyle işimi görmüyor. Benim istediğim tuşa basınca makronun çalışması için önce şifre sorması şifre doğru olunca Çalışma Kitabını Koru şifresini kaldırsın (Çalışma Kitabını Koru şifresi : 10 dur) gizli olan yetki sayfasını görünür yapıp yetki sayfasını mail atacak sonra yetki sayfasını tekrar gizleyip Çalışma Kitabını Koru şifresini yeniden koyacak ve ANA SAYFA ya dönecek.

 

[EmrExcel16]

Merhaba , vermiş olduğunuz kodları dikkate almadan, aşağıda verdiğim yeni kodları deneyiniz..

Option Explicit
Sub Yetki_Sayfasi_MailAt()
    Dim DsyYol, Dsy, OutApp, OutMail, Sifre, MailSayf, InpSifre
    Sifre = "10"
    Set MailSayf = Worksheets("yetki")
Basadon:
    InpSifre = InputBox("Sifre gir..", "Calisma Kitabi Sifresi")
    If InpSifre = "" Then Exit Sub
    If InpSifre = Sifre Then
        Application.ScreenUpdating = False
        ThisWorkbook.Unprotect Sifre
        MailSayf.Visible = True
        On Error Resume Next
        ThisWorkbook.Worksheets(MailSayf.Name).Copy
        DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") + "\"
        Dsy = MailSayf.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        ActiveWorkbook.SaveAs DsyYol & Dsy
        With OutMail
            .To = "EmrExcel16.@Test.com"
            .CC = "EmrExcel16.@Test.com"
            .Subject = Dsy
            .Body = "Merhaba ," & Chr(13) & Chr(13) & "Bilginize.." & Chr(13) & Chr(13) & "İyi calismalar..."
            .Attachments.Add ActiveWorkbook.FullName
            .Display
            '.Send  Mail atilmasi icin tirnagi kaldir
        End With
        ActiveWorkbook.Close SaveChanges:=False
        Kill DsyYol & Dsy & ".xlsx"
        Set OutMail = Nothing
        Set OutApp = Nothing
        MailSayf.Visible = False
        ActiveWorkbook.Protect Sifre
        Application.ScreenUpdating = False
    Else
        MsgBox "Sifre yanlis tekrar deneyiniz.."
        GoTo Basadon
    End If
End Sub

 

[TURKOLOG]

Sayın @EmrExcel16 kod çalıştı. Çok teşekkür ederim .

 

[EmrExcel16]

Sayın @EmrExcel16 kod çalıştı. Çok teşekkür ederim .

Rica ederim , iyi çalışmalar.

 

[TURKOLOG]

@EmrExcel16 Bey iyiki varsınız. Hiç yorulmadan herkese yardim ediyorsunuz. Teşekkür ederim .

 

[Hacı Bayram ÖZKAN]

Aynen öylesiniz

 

[EmrExcel16]

@EmrExcel16 Bey iyiki varsınız. Hiç yorulmadan herkese yardim ediyorsunuz. Teşekkür ederim .

Aynen öylesiniz

Tüm üstadlarımız aynı şekilde, çok teşekkür ederiz sağolun , iyi çalışmalar.