Email gönderme işlemi

ismailayan · 2 Mayıs 2006

Merhaba arkadaşlar..

Yapmak istediğim usta gerektiren bir şey ama....

Yapmak istediğim..

Benim projemde visual basic de exceli kulanarak rapor ve yazdırma işlemi yapıyorum. ama kaydetmiyorum dosyayı

buraya kadar güzel ama
düğmeye basdığımda geçiçi olarak yarıtılan dosyayı istediğim mail adresine göndermek istiyorum...

önceki formlara baktım ama maalesef yok..

bu konuda bana yardımcı olurmusunuz???

xxrt · 2 Mayıs 2006

http://www.excel.web.tr/viewtopic.php?p=38529#38529

Outlook Ekspre ile:

http://www.rondebruin.nl/mail/folder1/mail2.htm

Kod:

Sub Mail_ActiveSheet()
    Dim wb As Workbook
    Dim strdate As String
    strdate = Format(Now, "dd-mm-yy h-mm-ss")
    Application.ScreenUpdating = False
    ActiveSheet.Copy
    Set wb = ActiveWorkbook
    With wb
        .SaveAs "Part of " & ThisWorkbook.Name _
              & " " & strdate & ".xls"
              'a1 Hücresine e-mail girilmesi için değişken
              x = [a1] 'a1 Hücresine e-mailadresi girin
        .SendMail x, _
                  "This is the Subject line"
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close False
    End With
    Application.ScreenUpdating = True
End Sub

/////****
Birden fazla kişiye

Kod:

Sub Mail_test()
    Dim wb As Workbook
    Dim strdate As String
    Dim Shname As Variant
    Dim Addr As Variant
    Dim N As Integer

    strdate = Format(Now, "dd-mm-yy h-mm-ss")
    Shname = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
    Addr = Array("ron@test.nl", "jelle@test.nl", "judith@test.nl", "nicolet@test.nl")

    Application.ScreenUpdating = False

    For N = LBound(Shname) To UBound(Shname)
        Sheets(Shname(N)).Copy
        Set wb = ActiveWorkbook
        With wb
            .SaveAs "Sheet " & Shname(N) _
                  & " " & strdate & ".xls"
            .SendMail Addr(N), _
                      "This is the Subject line"
            .ChangeFileAccess xlReadOnly
            Kill .FullName
            .Close False
        End With
    Next N
    Application.ScreenUpdating = True
End Sub

//////////*

Outlook ile

Kod:

'******************************************************
'*  Sadece Aktif sayfayı MS Outlook ile yollamak için *
'*  yapılmış bir çalışmadır                           *
'*  Micosoft Outlook X.0 referansı eklenmelidir !     *
'*          Burası Excel vadisi ...                   *
'*               Raider ®                             *
'*              Şubat 2005                            *
'******************************************************

Sub SendShByEmail()
    Dim OutApp As Outlook.Application
    Dim NewMail As Outlook.MailItem
    Dim ShName As String, WbName As String
    Dim i As Integer
    Dim ModX As Object, VBComp As Object
    
    ShName = ActiveSheet.Name
    WbName = "C:\" & ShName & ".xls"
    
    ThisWorkbook.SaveCopyAs WbName
    
    Application.DisplayAlerts = False
        Workbooks.Open WbName
        For i = Sheets.Count To 1 Step -1
            If ActiveWorkbook.Sheets(i).Name <> ShName Then Sheets(i).Delete
        Next
        
        On Error Resume Next
        For Each ModX In ActiveWorkbook.VBProject.VBComponents
            Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
            ActiveWorkbook.VBProject.VBComponents.Remove VBComp
        Next
        On Error GoTo 0
    Application.DisplayAlerts = True
    
    ActiveWorkbook.Close SaveChanges:=True
    
    Set OutApp = New Outlook.Application
    Set NewMail = CreateItem(olMailItem)
        With NewMail
            .To = "falan@filan.com"
            .Subject = "Deneme"
            .Body = "Bu e-mail deneme amacıyla gönderilmiştir."
            .Attachments.Add WbName
            .Save
            .Send
        End With
    Set NewMail = Nothing
    Set OutApp = Nothing
    Set VBComp = Nothing
    Kill WbName
End Sub

Kodlar forumdan alınmıştır.Linklerini bulamadım.

ismailayan · 3 Mayıs 2006

excelden email gönderme

arkadaşlar..

Gerçi bu konuyu daha önce sormuştum ama yeterli cevabı aldım.. ama visual basic üzerinde exceli açıp email gönderme işlemi hem zaman alıyor. hemde makineyi çok kasıyor.. XP işletim sistemiyle çalıştığım için önceden açık olan excel üzerinde işlem yapıyor..

Aklıma bir fikir geldi ama doğal işi ustalara sormakta gerek duydum..

Excel içerisinde zaten email gönderebiliyorsun...

Excele akra fonda dökümü aldırım excelin kendi email göndermi işlemi olabilirmi??

üst menülerde E-Posta simgesini kullanmak istiyorum...

visual basic üzerinde bu işlemi gerçekleştirmek istiyorum...

bu konuda bana yardımcı olurmusunuz??

ismailayan · 3 Mayıs 2006

Yapmak istediğim resimleri gönderiyorum

xxrt · 3 Mayıs 2006

Son iki başlık buraya taşındı.

ismailayan · 3 Mayıs 2006

xxrt' Alıntı:
Son iki başlık buraya taşındı.

anlamadım bu ne demek şimdi...

webde araştırdım ama yok gibi

bu konu benim için çok önemli...

lütfen bu konuda bana yardımcı olun..

ismailayan · 3 Mayıs 2006

Private Sub Command1_Click()

Dim XlApp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim A, i As Long
Set XlApp = New Excel.Application
Set XlBook = XlApp.Workbooks.Add
Set XlSheet = XlBook.Worksheets(1)

XlApp.Visible = True
For A = 1 To 10
For i = 1 To 10
'XlSheet.Cells(1, A).Font.Bold = True
XlSheet.Cells(i, A) = "a"
'XlSheet.Cells(i, A).HorizontalAlignment = xlLeft
'XlSheet.Cells(i, 3).NumberFormat = "###0"

Next i
Next A

XlApp.ActiveWorkbooks.SendMail ("floclub@flo.com.tr"), "Gönder", True
'XlApp.ActiveWorkbook.Close
'XlApp.ActiveWorkbook.Saved = False

XlBook.Close
XlApp.Quit
XlBook.Saved = True

Set XlApp = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
MsgBox "email gönderildi"
End Sub

kodlarım yukarda

ama
XlApp.ActiveWorkbooks.SendMail ("floclub@flo.com.tr"), "Gönder", True

kısmı hata veriyor
Hata:
Run time error :438
object doesent support this property or method

bu konuda bana yardımcı olun lütfen

ismailayan · 3 Mayıs 2006

arkadaşlar elimdeki kodu gönderiyorummmm
----------------------------------------------------
Dim XlApp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim A, i As Long
Set XlApp = New Excel.Application
Set XlBook = XlApp.Workbooks.Add
Set XlSheet = XlBook.Worksheets(1)

XlApp.Visible = True
For A = 1 To 10
For i = 1 To 10
XlSheet.Cells(i, A) = "a"
Next i
Next A

XlApp.ActiveWorkbook.SendMail "floclub@flo.com.tr", True

XlBook.Close
'XlBook.Saved = True
XlApp.Quit

Set XlApp = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
-------------------------------------------------------------

ismailayan · 3 Mayıs 2006

Cevap Bekliyorum arkadaşlar...

Bi el atın şu koda allah aşkına

cevabınızı bekliyorum

L_M · 3 Mayıs 2006

Micosoft Outlook 10.0 referansı ekledin mi arkadaşım.

ismailayan · 3 Mayıs 2006

hayır arkadaşım eklemedim.

yanlış ilerliyorum galiba

reference kısmında outlok yok...

yardımını bekliyorum arkadaşımmmm..

size tüm kodları gönderiyorum...

Option Explicit

Private DataAvailable As Boolean
Dim inData As String
Private timer As Long
Private change As Boolean
Private Const TIME_OUT = 30

Private Sub Check1_Click()
If Check1.Value = 1 Then
Check1.Tag = "html;" 'HTML E-mail
Else
Check1.Tag = "plain;" 'Plain text E-mail
End If
End Sub

Private Sub Command1_Click()
On Error Resume Next
Dim XlApp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim A, i As Long
Set XlApp = New Excel.Application
Set XlBook = XlApp.Workbooks.Add
Set XlSheet = XlBook.Worksheets(1)

XlApp.Visible = True
For A = 1 To 10
For i = 1 To 10
XlSheet.Cells(i, A) = "a"
Next i
Next A

XlApp.ActiveWorkbook.SendMail "floclub@flo.com.tr", True

XlBook.Close
'XlBook.Saved = True
XlApp.Quit

Set XlApp = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
MsgBox "Email gönderildi"
End Sub

Private Sub Form_Load()
Dim i As Integer
Dim str As String
DataAvailable = False
timer = 0
change = False
On Error GoTo errhandler
Open "servers.txt" For Input As #1 'Open SMTP server list file
While Not EOF(1)
Line Input #1, str
List1.AddItem Trim(str)
Wend
Close #1
Exit Sub
errhandler:
MsgBox "Error opening servers.txt"
End
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
If Not Number = sckSuccess Then
MsgBox Description 'Display error
Timer1.Enabled = False
CloseConn True
End If
End Sub

Private Sub cmdSend_Click()
If MsgBox("E-Mail Göndermek istiyormusunuz?", vbYesNo, "Gönderme Onayı") = vbYes Then
Dim tmp() As String
tmp = Split(List1.List(List1.ListIndex), ":")
cmdSend.Enabled = False
cmdSend.Caption = "Bağlanılıyor..."
Winsock1.Connect tmp(0), Val(tmp(1))
txtSender.Enabled = False
txtReceiver.Enabled = False
txtSubject.Enabled = False
txtMessage.Enabled = False
List1.Enabled = False
End If
End Sub

Private Sub Winsock1_DataArrival _
(ByVal bytesTotal As Long)
Dim data As String
Winsock1.GetData data, vbString
inData = inData + data
If StrComp(Right$(inData, 2), vbCrLf) = 0 Then DataAvailable = True
End Sub
Private Sub Winsock1_Connect()
cmdSend.Caption = "Bağlantı Kuruldu"
timer = 0
Timer1.Enabled = True
While Not DataAvailable
If Winsock1.State = sckClosed Then Exit Sub
DoEvents
Wend
Timer1.Enabled = False

Dim reply As String
Dim tmp() As String
reply = inData
inData = ""
DataAvailable = False
tmp = Split(reply, " ")
If Not Val(tmp(0)) = 220 Then
MsgBox "Server returned the following error:" + vbCrLf + reply
CloseConn False
Exit Sub
End If
cmdSend.Caption = "Receiving Welcome Message"

Winsock1.SendData "HELO " + Winsock1.LocalHostName + vbCrLf
DoEvents
timer = 0
Timer1.Enabled = True
While Not DataAvailable
If Winsock1.State = sckClosed Then Exit Sub
DoEvents
Wend
Timer1.Enabled = False
reply = inData
inData = ""
DataAvailable = False
tmp = Split(reply, " ")
If Not Val(tmp(0)) = 250 Then
MsgBox "Server returned the following error:" + vbCrLf + reply
CloseConn False
Exit Sub
End If

Winsock1.SendData "MAIL FROM:<" + txtSender.Text + ">" + vbCrLf
DoEvents
timer = 0
Timer1.Enabled = True
While Not DataAvailable
If Winsock1.State = sckClosed Then Exit Sub
DoEvents
Wend
Timer1.Enabled = False
reply = inData
inData = ""
DataAvailable = False
tmp = Split(reply, " ")
If Not Val(tmp(0)) = 250 Then
MsgBox "Server returned the following error:" + vbCrLf + reply
CloseConn True
Exit Sub
End If

Winsock1.SendData "RCPT TO:<" + txtReceiver.Text + ">" + vbCrLf
DoEvents
timer = 0
Timer1.Enabled = True
While Not DataAvailable
If Winsock1.State = sckClosed Then Exit Sub
DoEvents
Wend
Timer1.Enabled = False
reply = inData
inData = ""
DataAvailable = False
tmp = Split(reply, " ")
If Not Val(tmp(0)) = 250 Then
MsgBox "Server returned the following error:" + vbCrLf + reply
CloseConn True
Exit Sub
End If

DoEvents
Winsock1.SendData "DATA" + vbCrLf
DoEvents
timer = 0
Timer1.Enabled = True
While Not DataAvailable
If Winsock1.State = sckClosed Then Exit Sub
DoEvents
Wend
Timer1.Enabled = False
reply = inData
inData = ""
DataAvailable = False
tmp = Split(reply, " ")
If Not Val(tmp(0)) = 354 Then
MsgBox "Server returned the following error:" + vbCrLf + reply
CloseConn False
Exit Sub
End If
cmdSend.Caption = "Mail Gönderiliyor . . ."

Winsock1.SendData "From: <" + txtSender.Text + ">" + vbCrLf + _
"To: " + txtReceiver.Text + vbCrLf + _
"Subject: " + txtSubject.Text + vbCrLf + _
"X-Mailer: anyMail v1.1" + vbCrLf + _
"Mime-Version: 1.0" + vbCrLf + _
"Content-Type: text/" + Check1.Tag + vbTab + "charset=us-ascii" + vbCrLf + vbCrLf + _
txtMessage.Text
Winsock1.SendData vbCrLf + "." + vbCrLf
DoEvents
timer = 0
Timer1.Enabled = True
While Not DataAvailable
If Winsock1.State = sckClosed Then Exit Sub
DoEvents
Wend
Timer1.Enabled = False
reply = inData
inData = ""
DataAvailable = False
tmp = Split(reply, " ")
If Not Val(tmp(0)) = 250 Then
MsgBox "Server returned the following error:" + vbCrLf + reply
CloseConn False
Exit Sub
End If
Winsock1.SendData "QUIT"
MsgBox "E-Mailiniz Gönderildi", vbInformation, "E-Mailiniz iletilmiştir"
CloseConn False
End Sub

Private Sub Timer1_Timer()
timer = timer + 1
If timer = TIME_OUT Then
CloseConn True 'Disconnect if timed out
MsgBox "Could not connect to host " + List1.List(List1.ListIndex) + vbCrLf + "Operation timed out"
Timer1.Enabled = False
End If
End Sub
Private Sub CloseConn(Err As Boolean)
Winsock1.Close
cmdSend.Caption = "Gönder"
cmdSend.Enabled = True
txtSender.Enabled = True
txtReceiver.Enabled = True
txtSubject.Enabled = True
txtMessage.Enabled = True
List1.Enabled = True

End Sub

---------
outlok dll dosyasını nerden bulabilirim...

ismailayan · 3 Mayıs 2006

Yardım edin lütfen

kimse yokmu...

çok zor durumdayım....

cevabınızı bekliyorum....

xxrt · 3 Mayıs 2006

çok zor durumdayım....

Normal yolla gönderin dosyanızı zor durumunuz kolaylaşsın..

Sayın ismailayan,
Private Sub Command1_Click()

kısmını

Private Sub CommandButton1_Click() olarak değiştirin bakalım.

ismailayan · 3 Mayıs 2006

tamam arkadaşım gönderiyorum lütfen yardım et bana

xxrt · 3 Mayıs 2006

Sakin ol..İkidebir başlık açıp durma..Bu forumda bu tür hareketlere izin vermiyoruz.

ismailayan · 3 Mayıs 2006

özür dilerim arkadaşım..
benim amacım olayın beim için olan ciddiyetini göstermekti...

bu konuda bana yardımcı olun lütfen...

o olmassa
exceldeki email gönderme simgesini ne şekilde kullanabilirim . gösterirseniz.
benim için bu proje çok anlam taşıyor...

yapılması gerekeni ben resim olarak hazırladım
belki çalışmamıza yardımcı olur...

olma ihtimali varmı acaba bana cevap yazarsanız

cagdaser · 15 Temmuz 2016

Çok işime yaradı teşekkür ederim... elinize sağlık

Email gönderme işlemi

ismailayan

xxrt

Misafir

ismailayan

ismailayan

xxrt

Misafir

ismailayan

ismailayan

ismailayan

ismailayan

L_M

ismailayan

ismailayan

xxrt

Misafir

ismailayan

xxrt

Misafir

ismailayan

cagdaser