TURKOLOG
Altın Üye
- Katılım
- 13 Kasım 2008
- Mesajlar
- 744
- Excel Vers. ve Dili
- 2016 64 TR
- Altın Üyelik Bitiş Tarihi
- 29-10-2026
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
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.
Elimdeki aşağıda yazdığım kod çalışmakta ve sadece belirli bir sayfayı mail göndermektedir. Kod bu anlamda sorunsuz çalışmaktadır
Kod:
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