outlook makrosu ve otomatik imza hakkında yardım.

[direnist]

Herkese merhaba;

Excelden makro yardımı ile otomatik olarak outlook üzerinden yolladığım günlük raporumun makro kodlamasındaki “.body=” bölümüne yazdığım sabit açıklamalarım haricinde, outlook’ta kayıtlı olan daha önce hazırlamış olduğum Signature (otomatik imzamın)’ünde gözükmesini nasıl sağlarım.

Herkese yardımları için şimdiden teşekkür ederim.

 

[direnist]

Acaba sorumu yanlış yerdemi sordum???..Soruyu aktarmam gereken bir yer varmı?
Teşekkürler..........

 

[ersoyalan]

Arkadaşım yeni bir modul yaratıp aşağıdaki kodları kopyala....Bu şekilde imza ekliyebilirsin......


ption Explicit

Sub Mail_workbook_Outlook_1()
'Working in 2000-2007
'This example send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = "xxxxxx@com.tr"
.CC = "xxxxx@com.tr"
.BCC = ""
.Subject = "Rapor"
.Body = "Merhaba," & Chr(13) & Chr(13) & _
"Rapor ektedir." & Chr(13) & Chr(13) & _
"Saygılarımızla," & Chr(13) & Chr(13) & _
"xxxxxxxxxxxx" & Chr(13) & Chr(13) & _
"Tel0212) xxx xx xx" & Chr(13) & Chr(13) & _
"Tel0212) xxx xx xx" & Chr(13) & Chr(13) & _
"e-mail:xxxxxxxxxxxx@com.tr" & Chr(13) & Chr(13)
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
.Display 'or use .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[Haluk]

MS Outlook'da kullandığınız imzanın HTML formatında olduğunu ve sözkonusu imzanın da C:\Signature.htm dosyasını olduğunu kabul edersek, aşağıdaki gibi bir kod işinizi görecektir.

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim MySignature As Object
    
    Set FSO = CreateObject("Scripting.FilesystemObject")
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)

    Set MySignature = FSO.OpenTextFile("C:\Signature.htm", 1)
    
    With OutlookMsg
        .HTMLBody = "Test mesajıdır...."
        .HTMLBody = .HTMLBody & "<br><br><br>" & MySignature.ReadAll
        .Subject = "Deneme mesajı"
        .To = "raider@hotmail.com"
        .CC = "raider@yahoo.com"
        .Display
'        .Send
    End With
       
    Set MySignature = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set FSO = Nothing
End Sub

 

[Haluk]

Not:

Eğer oluşturduysanız, normal şartlarda MS Outlook imzası aşağıdaki "Gizli görünümdeki" klasörde bulunur;

....Documents and Settings\Kullanıcı Adı\Application Data\Microsoft\Signatures


.

 

[direnist]

Haluk Bey yardımlarınız için teşekkür ederim.ama biraz acemi olduğum için yapamadım...Kullandığım kod aşağıdaki gibidir...Bunu başka bir yerden alıp uyarlamıştım..Sizin bahsettiğiniz kodu başka bir modül açmadan burata buraya nasıl ekleyebiliriz.
Kodda .body kısmında benim manuel olarak yazdığım imza var..ama ben outlookta yazılı olanın gelmesini istiyorum...tekrardan çok teşekkürler.

Sub RAPOR_GONDER()

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

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
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

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "sibel.guner@xxx.com.tr; "
.CC = "murat.kayhan@xxx.com.tr"
.BCC = ""
.Subject = [SON_HAL!B2] & " " & "TAR&#304;HL&#304; GGSOFT G&#220;N SONU SAYILARIDIR."
.Body = "Bilgilerinize sunar&#305;m." & vbCr & "" & vbCr & "Diren SARISALTIKO&#286;LU" & vbCr & "PK Veri Giri&#351; ve Kontrol" & vbCr & "Tel:0216-5222222" & vbCr & "E-mail:diren.sarisaltikoglu@xxx.com.tr"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

 

[Haluk]

Bu &#351;ekilde deneyiniz;

Sub RAPOR_GONDER()

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

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
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

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

If Dir("C:\Signature.htm") = "" Then
    MsgBox "C:\Signature.htm" & " dosyas&#305; bulunamad&#305;..."
    Exit Sub
End If

Set FSO = CreateObject("Scripting.FilesystemObject")
Set MySignature = FSO.OpenTextFile("C:\Signature.htm", 1)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "sibel.guner@xxx.com.tr; "
.CC = "murat.kayhan@xxx.com.tr"
.BCC = ""
.Subject = [SON_HAL!B2] & " " & "TAR&#304;HL&#304; GGSOFT G&#220;N SONU SAYILARIDIR."
.HTMLBody = "Bilgilerinize sunar&#305;m." & "<br><br><br>" & "Diren SARISALTIKO&#286;LU" & "<br><br><br>" & "PK Veri Giri&#351; ve Kontrol" & "<br><br><br>" & "Tel:0216-5222222" & "<br><br><br>" & "E-mail:diren.sarisaltikoglu@xxx.com.tr"
.HTMLBody = .HTMLBody & "<br><br><br>" & MySignature.ReadAll

.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

 

[direnist]

Tamamd&#305;r Haluk Bey yard&#305;m&#305;n&#305;z i&#231;in &#231;ok te&#351;ekk&#252;r ederim...Tekrar bir sorunla kar&#351;&#305;la&#351;&#305;rsam rahats&#305;z edebilirim dimi....?...