E mail gönderirken klasöre dosyaları sırayla kaydetmek

[sakincekirge]

Merhaba Arkadaşlar;

Yazdığım dosya bu forumdan öğrendiğim e-mail kodunu koydum. Ve e-mail gönderilecek alanı seçtim,kod şu:

Sub EmailSheet()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object, BodyText As Object
    Dim MyRange As Range, TempFile As String
    
    On Error Resume Next
    Set MyRange = ActiveSheet.Range("A1:H30")
    If MyRange Is Nothing Then Exit Sub
    Set FSO = CreateObject("Scripting.FilesystemObject")
    TempFile = "C:\TempHTML.htm"
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
    Set BodyText = FSO.OpenTextFile(TempFile, 1)
    
        With OutlookMsg
            .HTMLBody = BodyText.ReadAll
            .Subject = Range("A34").Text
            .To = ""
            .cc = ""
            .Display
        End With
        
    Kill TempFile
    
    Set BodyText = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set FSO = Nothing
End Sub

Bu koduda bir düğmeye bağladım. Þimdi yapmak istediğim bu düğmeye tıkladıktan sonra belirteceğim yoldaki klasörün içine o günkü tarih - no olarak kayıt yapması. 12.11.2005-1;eğer bir tane daha dosya gönderilire 12.11.2005-2 olarak. yardımlarını bekliyorum. Teşekkürler.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin. Mavi satırlar ilavelerdir. Kaydedilecek klasörde C:\kopya kabul edilmiştir.

[vb:1:cf51b907fb]Dim c As Integer
Sub EmailSheet()
Dim OutlookApp As Object, OutlookMsg As Object
Dim FSO As Object, BodyText As Object
Dim MyRange As Range, TempFile As String

On Error Resume Next
Set MyRange = ActiveSheet.Range("A1:H30")
If MyRange Is Nothing Then Exit Sub
Set FSO = CreateObject("Scripting.FilesystemObject")
TempFile = "C:\TempHTML.htm"
ActiveWorkbook.PublishObjects.Add _
(4, TempFile, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMsg = OutlookApp.CreateItem(0)
Set BodyText = FSO.OpenTextFile(TempFile, 1)

With OutlookMsg
.HTMLBody = BodyText.ReadAll
.Subject = Range("A34").Text
.To = ""
.cc = ""
.Display
End With

Kill TempFile

Set BodyText = Nothing
Set OutlookMsg = Nothing
Set OutlookApp = Nothing
Set FSO = Nothing

c = c + 1
ActiveWorkbook.SaveCopyAs Filename:="C:\kopya\" & Date & "-" & c & ".xls"

End Sub[/vb:1:cf51b907fb]