Aktif Sayfayı e-mail ile gönder

hsayar · 22 Ocak 2008

alıcıyı :textbox1'den
açıklamayı :textbox2'den
Eklenti(Attacment): Aktif sayfa

olacak şekilde userform command butonu ile Outlook 2003 programı ile elmek nasıl gönderilir.

Necdet · 22 Ocak 2008

Merhaba,

Birkaç gün önce Sayın Leventm'nin verdiği adresi öneririm size.

http://www.rondebruin.nl/tips.htm

hsayar · 22 Ocak 2008

hocam dil sorunumdan dolayı aradığımı bulamadım ama uzun bir incelemeden sonra herhalde bulurum.

Haluk · 22 Ocak 2008

Bir de aşağıdaki linkte yer alan 6 No'lu mesaja göz atın....

http://www.excel.web.tr/showpost.php?p=8799&postcount=6

hsayar · 22 Ocak 2008

teşekkürler hocam bakıpda görememiştim.
yalnız şöyle bir sorun var

.to satırındaki "falan@filan.com" u kendi emmekim olan
.to satırındaki "huseyin_sayar@hotmail.com" olarka değiştirmeme rağmen

posta kutusunda mesaj gözükmemektedir.

sebebleri nedir?

Haluk · 22 Ocak 2008

O mesajda belirtildiğiüzere, kodların yer aldığı dosyaya ilgili "Micosoft Outlook X.0 referansı eklenmelidir !"

Daha sonra dosyayı kaydedip, makroyu çalıştırın.

Verdiğim linkteki kodların okunabilirliğini düzeltmek için burada tekrar veriyorum.

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 ®                                           *
'* Subat 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

hsayar · 22 Ocak 2008

hocam outlok 11.0 referanslarda seçili halde...

outloku açınca hesabımın giden kutusunda ilgili iletiler gözüküyor (huseyin_sayar@hotmail.com, falan@filan.com) ama webde hesabımı açınca ileti gözükmüyor. ben bunu anlamadım.?

Haluk · 22 Ocak 2008

Ben gmail hesabıma gönderdim, herhangibir sorun olmadı....

hsayar · 22 Ocak 2008

evet hocam gmaile gönderdi.
Aşağıdaki yönerge ile outlaka gmail kurdum
http://mail.google.com/support/bin/answer.py?hl=tr&answer=77661

aam inboxunı göremiyorum neyse gönderdi ya

hsayar · 22 Ocak 2008

hocam burada maili yayınladık gitti mail
live id var olmadığından oturum açılamıyor diyor. nasıl geri alacağız bilenler özle mesaj atsın

hsayar · 23 Ocak 2008

Hocam şimdi bir sorun ortaya çıktı kaynağı nedir bilmiyorum.
kodlarınızı biraz revize etttim umarım kısmazsınız.
Aşğaıdaki kodlar bir butona bağlı butona basınca e-postayı outlokun Kişisel klasörler/Giden kutusu kısmına alıyor. Outloku başlat deyince "Klasörleri eşitleyerek" e-posta-yı/ları adrese teslim ediyor.

bunu aşabilirmiyiz?

Kod:

Private Sub CommandButton2_Click()
'******************************************************
'* Sadece Aktif sayfay&#305; MS Outlook ile yollamak i&#231;in  *
'* yap&#305;lm&#305;&#351; bir &#231;al&#305;&#351;mad&#305;r                            *
'* Micosoft Outlook X.0 referans&#305; eklenmelidir !      *
'* Buras&#305; Excel vadisi ...                            *
'* Raider &#174;                                           *
'* Subat 2005                                         *
'******************************************************
'<<<<<<<<<<<<<<<<<<<<<<<KONTROLLER>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    'Aktif internet ba&#287;lant&#305;s&#305; varm&#305; kontrol et.
    If TestInternetConnection = False Then
        MsgBox "BA&#286;LANTI YOK": Exit Sub
    End If
    
    'Micosoft Outlook X.0 referans&#305; yoksa ekler....
    Dim bool As Boolean
    strRefPath = "C:\Program Files\Microsoft Office\OFFICE11\msoutl.olb" 'ADO
    bool = False
    For Each ref In ThisWorkbook.VBProject.References
        If ref.fullPath = strRefPath Then bool = True
    Next
    If bool = False Then ThisWorkbook.VBProject.References.AddFromFile (strRefPath)
    
    'Nesne Kontrol
    For Each nsn In Controls
    If TypeName(nsn) = "TextBox" Then  ' NESNENIN ADI YAZILACAK
        If nsn.Value = "" Then
            aa = Replace(nsn.Name, "txt", "lbl")
            MsgBox Controls(aa).Caption & " Textboxu Bo&#351; B&#305;rak&#305;lamaz!"
            nsn.SetFocus: Exit Sub
        End If
    End If
    Next nsn
    'MsgBox "kontroller tamamland&#305;.":    Exit Sub
'<<<<<<<<<<<<<<<<<<<<<<<&#304;&#350;LEMLER>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim OutApp As Outlook.Application
    Dim NewMail As Outlook.MailItem
    Dim ShName As String, WbName As String
    Dim i As Integer
   ' Aktif Sayfay&#305; yeni kitaba kopyala ve kapat
    ShName = ActiveSheet.Name:                  Sheets(ShName).Copy
    WbName = "C:\" & ShName & ".xls":           ActiveWorkbook.SaveAs WbName
    Workbooks(ShName & ".xls").Close SaveChanges:=True

   'Olu&#351;turulan kitab&#305;  e-mail ile g&#246;nder
    Set OutApp = New Outlook.Application
    Set NewMail = CreateItem(olMailItem)
    
    StrKime = txtKime.Value
    strKonu = txtKonu.Value
    strMsj = txtMsj.Value
    
    With NewMail
        .To = StrKime '"xxxxx@hotmail.com"
        .Subject = strKonu '"Deneme"
        .Body = strMsj '"Bu e-mail deneme amac&#305;yla g&#246;nderilmi&#351;tir."
        .Attachments.Add WbName
        .Save
        .Send
    End With
    
    'Tamamland&#305; mesaj&#305;:
    MsgBox StrKime & " adresine" & ShName & " sayfas&#305; g&#246;nderildi."
    'olu&#351;turulmu&#351; de&#287;i&#351;&#351;ken ve dosyalar&#305; sil....
    Set NewMail = Nothing:    Set OutApp = Nothing
    Kill WbName
End Sub

Haluk · 23 Ocak 2008

Bu konu sizin MS Outlook ayarlarınızla ilgili görünüyor, yukarıdaki kodlarla hiçbir ilgisi yok.

hsayar · 23 Ocak 2008

peki sizde direk gidiyorsa nasıl olmalı...

outlooku başlat dedikten sonra (ikonu sistem saatinin yanında iken)
Set NewMail = CreateItem(olMailItem)
satırında hata veriyor.

neyse benim aklıma şöye bir şey geldi....
Excel vba dan outlok klasörlerini eşitle makrosu yazılabilirmi

ünal karadavut · 23 Ocak 2008

eğer aktif excel veya word sayfası e-posta yolu ile gönderebilirsek tüm resmi yazılar istenen yere gönderilir ve bu sayede devlet posta parası vermekten çok kara geçecek.

inşallah sonuç bulunur.

emek verenlerden allah razı olsun.

hsayar · 23 Ocak 2008

şu anda gönderiyor ünal hocam gönderdikten sonra bende outloku başlat demek gerekiyor. bunu otomatik yapmanın yollarını arıyorum

ünal karadavut · 23 Ocak 2008

ama nasıl gönderildiğini ben bilmiyorum.

hsayar · 23 Ocak 2008

Modul1

Kod:

Sub AktifSayfayıGonder()
'******************************************************
'* 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 ®                                           *
'* Subat 2005                                         *
'******************************************************
'<<<<<<<<<<<<<<<<<<<<<<<KONTROLLER>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    'Aktif internet bağlantısı varmı kontrol et.
    If TestInternetConnection = False Then
        MsgBox "BAĞLANTI YOK": Exit Sub
    End If
    
    'Micosoft Outlook X.0 referansı yoksa ekler....
'    Dim bool As Boolean
'    strRefPath = "C:\Program Files\Microsoft Office\OFFICE11\msoutl.olb" 'ADO
'    bool = False
'    For Each ref In ThisWorkbook.VBProject.References
'        If ref.fullPath = strRefPath Then bool = True
'    Next
'    If bool = False Then ThisWorkbook.VBProject.References.AddFromFile (strRefPath)
    
    'MsgBox "kontroller tamamlandı.":    Exit Sub
'<<<<<<<<<<<<<<<<<<<<<<<İŞLEMLER>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim OutApp As Outlook.Application
    Dim NewMail As Outlook.MailItem
    Dim ShName As String, WbName As String
    Dim i As Integer
   ' Aktif Sayfayı yeni kitaba kopyala ve kapat
    ShName = ActiveSheet.Name:                  Sheets(ShName).Copy
    WbName = "C:\" & ShName & ".xls":           ActiveWorkbook.SaveAs WbName
    Workbooks(ShName & ".xls").Close SaveChanges:=True

   'Oluşturulan kitabı  e-mail ile gönder
    Set OutApp = New Outlook.Application
    Set NewMail = CreateItem(olMailItem)
    
[B]    StrKime = "xxxxxxxxxx@yyyyy.zzz"
    strKonu = "Deneme2136_modul"
    strMsj = "Bu e-mail deneme amacıyla gönderilmiştir."[/B]
    
    With NewMail
        .To = StrKime '"xxxxx@hotmail.com"
        .Subject = strKonu '"Deneme"
        .Body = strMsj '"Bu e-mail deneme amacıyla gönderilmiştir."
        .Attachments.Add WbName
        .Save
        .Send
    End With
    
    'Tamamlandı mesajı:
    MsgBox StrKime & " adresine " & ShName & " sayfası gönderildi."
    'oluşturulmuş değişşken ve dosyaları sil....
    Set NewMail = Nothing:    Set OutApp = Nothing
    Kill WbName
End Sub

modul2

Kod:

Option Private Module
Declare Function InternetCheckConnection Lib "wininet.dll" _
        Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, _
        ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
       
Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _
       (ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, _
        ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
'
Dim RunWhen As Double
Const RunWhat = "CheckInternetState"
'
Sub Auto_Open()
    Call CheckInternetState
End Sub
'
Sub StartTimer()
    RunWhen = Now + TimeSerial(0, 5, 0)
    Application.OnTime earliesttime:=RunWhen, Procedure:=RunWhat, Schedule:=True
End Sub
'
Sub StopTimer()
    On Error Resume Next
    Application.OnTime earliesttime:=RunWhen, Procedure:=RunWhat, Schedule:=False
End Sub
'
Sub Auto_Close()
    Call StopTimer
End Sub
'
Sub CheckInternetState()
Dim RetVal As Long
Dim strConn As String * 255
   ' Range("A1") = Empty
   ' Range("B1") = "Checking ...."
    If TestInternetConnection = True Then
     '   Range("A1") = TestInternetConnection
        RetVal = InternetGetConnectedStateEx(RetVal, strConn, 254, 0)
     '   Range("B1") = strConn
        Call StopTimer
        Exit Sub
    End If
    'Range("A1") = TestInternetConnection
    'Range("B1") = "No connection !"
    Call StartTimer
End Sub
'
Function TestInternetConnection() As Boolean
    'Adapted from :
    'KPD-Team 2001
    'URL: http://www.allapi.net/
    If (InternetCheckConnection("http://www.allapi.net/", &H1, 0&) = 0) Then
        TestInternetConnection = False
    Else
        TestInternetConnection = True
    End If
End Function

strKime satırında gerekli değişikliği yaptyıktan sonra
1. makroyu çalıştırdığınızda (araçlar>Makrolar>AktifSayfayıGonder)

ünal karadavut · 23 Ocak 2008

çok sağolun,

ama beceremedim.

hsayar · 23 Ocak 2008

ms outlook hesabınızı yapılandırın

mekist · 16 Mayıs 2009

Haluk' Alıntı:

O mesajda belirtildiğiüzere, kodların yer aldığı dosyaya ilgili "Micosoft Outlook X.0 referansı eklenmelidir !"

Daha sonra dosyayı kaydedip, makroyu çalıştırın.

Verdiğim linkteki kodların okunabilirliğini düzeltmek için burada tekrar veriyorum.

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 ®                                           *
'* Subat 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

Eline sağlık olsun mükemmel bir çalışma

Aktif Sayfayı e-mail ile gönder

hsayar

Necdet

Moderatör

hsayar

Haluk

Özel Üye

hsayar

Haluk

Özel Üye

hsayar

Haluk

Özel Üye

hsayar

hsayar

hsayar

Haluk

Özel Üye

hsayar

ünal karadavut

hsayar

ünal karadavut

hsayar

ünal karadavut

hsayar

mekist