Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 10-11-2017, 11:47   #11
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,368
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

Alıntı:
nkeles tarafından gönderildi Mesajı Görüntüle
Merhaba,
E fatura mükellefi bir firmada çalışıyorum. E faturalar entegratör firma tarafından ek olarak mail yoluyla iletiliyor. Bu faturalar hakkında yazışmalar yapıyoruz. Şirket içinde fatura maillerine, Onaylanmıştır, Red Edilmiştir, gibi dönüşler yapılıyor.
İsteğimiz örneğin İdari İşler den hangi e fatura için (efatura ek dosyasında efaturanın numarası yazılı) ne yazılmış excel e aktarılmasını istiyoruz.

Gönderen Fatura No Mail İçeriği Şeklinde Excel e rapor yapabilir miyiz.
Excel vba references de microsoft outlook v.xx seçili olmalı.

http://s4.dosya.tc/server5/b6nmh4/Ge...ntrol.zip.html



Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Dim lrow As Long
Dim ows As Worksheet
Dim bilgi As String

Sub GetFromInbox()
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    'Set oRootFldr = olApp.Session.PickFolder
    Set oRootFldr = olNs.GetDefaultFolder(6)
    Set ows = ActiveSheet
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    If sonsatir = 1 Then sonsatir = 2
    Range("A2:E" & sonsatir).ClearContents
    
    lrow = 2
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    GetFromFolder oRootFldr
   ' Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set ows = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
        If TypeName(oItem) = "MailItem" Then
            With oItem
               If InStr(.Subject, "Gelen Fatura") > 0 Then
                  Faturano = ""
                  For j = 1 To .Attachments.Count
                      dosya = .Attachments.Item(j).Filename
                      dosya = Mid(dosya, InStrRev(dosya, "-") + 1, Len(dosya))
                      uzanti = Mid(dosya, InStrRev(dosya, "."), Len(dosya))
                      dosya = Mid(dosya, 1, InStrRev(dosya, ".") - 1)
                      If uzanti = ".html" And Left(dosya, 2) = "BM" Then
                        Faturano = dosya
                        Exit For
                      End If
                  Next j

                  ows.Cells(lrow, 1).Value = fnGetSMTPAddress(.SenderEmailaddress)
                  ows.Cells(lrow, 2).Value = .Subject
                  ows.Cells(lrow, 3).Value = .ReceivedTime
                  ows.Cells(lrow, 4).Value = Faturano
                  bilgi = Replace(.body, Chr(13), "")
                  bilgi = Replace(.body, Chr(10), "")
                  bilgi = Replace(.body, "  ", " ")
                  ows.Cells(lrow, 5).Value = cleanString(bilgi)
                  lrow = lrow + 1
                
                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    'For Each oSubFldr In oFldr.Folders
    '    GetFromFolder oSubFldr
    'Next
End Sub


Function cleanString(text As String) As String
    Dim output As String
    Dim c As String
    For i = 1 To Len(text)
        c = Mid(text, i, 1) 'Select the character at the i position
        If Asc(c) > 64 Then
            output = output & c 'add the character to your output.
        Else
            output = output & " " 'add the replacement character (space) to your output
        End If
    Next
    cleanString = output
End Function

Public Function fnGetSMTPAddress(ExchangeMailAddress As String) As String
Dim objOutlook As Outlook.Application
Dim objMailItem As Outlook.MailItem

Set objOutlook = New Outlook.Application
Set objMailItem = objOutlook.CreateItem(0)
objMailItem.To = ExchangeMailAddress
objMailItem.Recipients.ResolveAll
On Error Resume Next
If objMailItem.Recipients.Item(1).Resolved Then
fnGetSMTPAddress = objMailItem.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
If Err.Number <> 0 Then fnGetSMTPAddress = ExchangeMailAddress
Else
fnGetSMTPAddress = ExchangeMailAddress
End If
Set objMailItem = Nothing
Set objOutlook = Nothing

End Function
__________________
www.asriakdeniz.com

Bu mesaj en son " 10-11-2017 " tarihinde saat 13:53 itibariyle asri tarafından düzenlenmiştir....
asri Çevrimdışı   Alıntı Yaparak Cevapla
Eski 10-11-2017, 11:49   #12
BedriA
Altın Üye
 
BedriA kullanıcısının avatarı
 
Giriş: 03/06/2017
Şehir: Antalya
Mesaj: 795
Excel Vers. ve Dili:
2007, 32
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Merhaba
Aşağıdaki gibi deneyebilirsiniz;
[/size]

Çok teşekkürler.
__________________
Demiri demirle dövdüler, biri sıcak biri soğuktu.
İnsanı insana kırdırdılar, biri aç biri toktu.

Pir Sultan Abdal
BedriA Çevrimdışı   Alıntı Yaparak Cevapla
Eski 10-11-2017, 13:12   #13
nkeles
 
Giriş: 13/07/2011
Şehir: İstanbul
Mesaj: 29
Excel Vers. ve Dili:
visual basic
Varsayılan

Alıntı:
asri tarafından gönderildi Mesajı Görüntüle
Excel vba references de microsft outlook v.xx seçili olmalı.

http://s4.dosya.tc/server5/b6nmh4/Ge...ntrol.zip.html



Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Dim lrow As Long
Dim ows As Worksheet
Dim bilgi As String

Sub GetFromInbox()
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    'Set oRootFldr = olApp.Session.PickFolder
    Set oRootFldr = olNs.GetDefaultFolder(6)
    Set ows = ActiveSheet
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    If sonsatir = 1 Then sonsatir = 2
    Range("A2:E" & sonsatir).ClearContents
    
    lrow = 2
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    GetFromFolder oRootFldr
   ' Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set ows = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
        If TypeName(oItem) = "MailItem" Then
            With oItem
               If InStr(.Subject, "Gelen Fatura") > 0 Then
                  Faturano = ""
                  For j = 1 To .Attachments.Count
                      dosya = .Attachments.Item(j).Filename
                      dosya = Mid(dosya, InStrRev(dosya, "-") + 1, Len(dosya))
                      uzanti = Mid(dosya, InStrRev(dosya, "."), Len(dosya))
                      dosya = Mid(dosya, 1, InStrRev(dosya, ".") - 1)
                      If uzanti = ".html" And Left(dosya, 2) = "BM" Then
                        Faturano = dosya
                        Exit For
                      End If
                  Next j

                  ows.Cells(lrow, 1).Value = fnGetSMTPAddress(.SenderEmailaddress)
                  ows.Cells(lrow, 2).Value = .Subject
                  ows.Cells(lrow, 3).Value = .ReceivedTime
                  ows.Cells(lrow, 4).Value = Faturano
                  bilgi = Replace(.body, Chr(13), "")
                  bilgi = Replace(.body, Chr(10), "")
                  bilgi = Replace(.body, "  ", " ")
                  ows.Cells(lrow, 5).Value = cleanString(bilgi)
                  lrow = lrow + 1
                
                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    'For Each oSubFldr In oFldr.Folders
    '    GetFromFolder oSubFldr
    'Next
End Sub


Function cleanString(text As String) As String
    Dim output As String
    Dim c As String
    For i = 1 To Len(text)
        c = Mid(text, i, 1) 'Select the character at the i position
        If Asc(c) > 64 Then
            output = output & c 'add the character to your output.
        Else
            output = output & " " 'add the replacement character (space) to your output
        End If
    Next
    cleanString = output
End Function

Public Function fnGetSMTPAddress(ExchangeMailAddress As String) As String
Dim objOutlook As Outlook.Application
Dim objMailItem As Outlook.MailItem

Set objOutlook = New Outlook.Application
Set objMailItem = objOutlook.CreateItem(0)
objMailItem.To = ExchangeMailAddress
objMailItem.Recipients.ResolveAll
On Error Resume Next
If objMailItem.Recipients.Item(1).Resolved Then
fnGetSMTPAddress = objMailItem.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
If Err.Number <> 0 Then fnGetSMTPAddress = ExchangeMailAddress
Else
fnGetSMTPAddress = ExchangeMailAddress
End If
Set objMailItem = Nothing
Set objOutlook = Nothing

End Function

Üstad link çalışmıyor.. Ayrıca kurulum konusunda desteğe ihtiyacım var.
nkeles Çevrimdışı   Alıntı Yaparak Cevapla
Eski 10-11-2017, 13:51   #14
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,368
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

Alıntı:
nkeles tarafından gönderildi Mesajı Görüntüle
Üstad link çalışmıyor.. Ayrıca kurulum konusunda desteğe ihtiyacım var.
Link çalışıyor, 3 indirim olmuş.
Çalışmıyor ise firmanız engellemiş olabilir. Bilgi işlemden destek alınız.

Kurulum konusunda özel birşey yok, outlook açık olacak, excel dosyasını çalıştırıp butona basacaksınız.
__________________
www.asriakdeniz.com
asri Çevrimdışı   Alıntı Yaparak Cevapla
Eski 10-11-2017, 14:21   #15
nkeles
 
Giriş: 13/07/2011
Şehir: İstanbul
Mesaj: 29
Excel Vers. ve Dili:
visual basic
Varsayılan

Aşağıdaki hatayı almaktayım..



nkeles Çevrimdışı   Alıntı Yaparak Cevapla
Eski 10-11-2017, 14:24   #16
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,368
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

Alıntı:
nkeles tarafından gönderildi Mesajı Görüntüle
Aşağıdaki hatayı almaktayım..

Dosyayı indirip mi denediniz? Kodu kopyala yapıştırıp yapıp mı denediniz?

Eğer kopyapa yapıştır yaptıysanız. Exce VBA bölümünde tools references de Microsoft outlook ... seçili olmalı.
__________________
www.asriakdeniz.com
asri Çevrimdışı   Alıntı Yaparak Cevapla
Eski 10-11-2017, 14:47   #17
nkeles
 
Giriş: 13/07/2011
Şehir: İstanbul
Mesaj: 29
Excel Vers. ve Dili:
visual basic
Varsayılan

Alıntı:
asri tarafından gönderildi Mesajı Görüntüle
Dosyayı indirip mi denediniz? Kodu kopyala yapıştırıp yapıp mı denediniz?

Eğer kopyapa yapıştır yaptıysanız. Exce VBA bölümünde tools references de Microsoft outlook ... seçili olmalı.
Sanıyorum çalıştı çünkü excel kilitlendi..
nkeles Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 19:55


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden