Merhaba, aşağıdaki kod ile excel sayfamın belli hücrelerini ayri kitap haline getirip koddaki mail adresine mail olarak gönderen bir çalışma var. Makro içeren bir butona tıklayınca bu işlemi yapıyorum. Ancak şöyle bir sorunum var. Maili outlook 2016 kullanarak gönderiyorum. Konu kısmına Günlük Faaliyet Raporu yazması gerekiyor ama yazmıyor. Garip çince bir iki karakter yazıyor. Ne yaptıysam çözemedim. Mail adresini eklediğim içinde değiştirmeme fırsat kalmadan maili göndermiş oluyor. Bunu nasıl düzeltebilirim. Yardımcı olursanız sevinirim.
Kod:
Sub mail_gonder_Modulile()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook, ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim strTempFile As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long
Dim shp As Shape
Dim MacroLink As String
Dim SplitLink As Variant
Dim NewLink As String
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
strTempFile = Environ$("temp") & "\" & "~tmpexport.bas"
wb.VBProject.VBComponents("Module2").Export strTempFile 'modülü dışarı al
Range("AS1:BI12").Select
Set Source = Nothing
On Error Resume Next
'1. BURASI SAYFA KORUMAYI KALDIR VE TEKRAR KOY
ws.Unprotect Password:="2023" 'ŞİFRE VARSA AYARLA
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
"Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Range("AS1").Select
ActiveWindow.Zoom = 55
ActiveWindow.ScrollColumn = Selection.Column
.Paste '2. BURASI SEÇİLİ ALANDAKİ BUTONLARI DA KOPYALAR/YAPIŞTIRIR
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteColumnWidths
.Range("AS1").Select
Application.CutCopyMode = False
End With
ws.Protect
TempFilePath = Environ$("temp") & "\"
TempFileName = Format(Now - 1, "dd-mm-yyyy") & " " & Format("Günlük Faaliyet Raporu")
If Val(Application.Version) < 12 Then
'Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'Excel 2007-2010
FileExtStr = ".xlsm": FileFormatNum = 52
End If
Dest.VBProject.VBComponents.Import strTempFile 'modülü içeri al
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
For Each shp In ActiveWorkbook.Sheets(1).Shapes
shp.Select
MacroLink = shp.OnAction
If MacroLink <> "" And InStr(MacroLink, "!") <> 0 Then
SplitLink = Split(MacroLink, "!")
NewLink = SplitLink(1)
If Right(NewLink, 1) = "'" Then
NewLink = Left(NewLink, Len(NewLink) - 1)
End If
shp.OnAction = "'" & TempFileName & FileExtStr & "'!" & NewLink
End If
Next shp
.Save
On Error Resume Next
For I = 1 To 3
'3. BURASI GÖNDERİLECEK MAİL ADRESİDİR
.SendMail Array("", "", "deneme@gmail.com.tr", "", ""), _
"Günlük Faaliyet Raporu"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Kill strTempFile
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Mail gönderildi", vbInformation
End Sub
