Write the senders Email to a text file (fighting spam)

Hi
I found this macro
Export Email Addresses - VBOffice

Code:

---

Private Const SenderFile As String = "c:\email addresses\senders.txt"
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub ExportSenderAddresses()
  On Error GoTo ERR_HANDLER
  Dim Sel As Outlook.Selection
  Dim Addresses As String
  Dim File As String
  Dim Hnd As Long
 
  Set Sel = Application.ActiveExplorer.Selection
  Addresses = GetSenderAddresses(Sel)
  If Len(Addresses) Then
    Hnd = FreeFile
    Open SenderFile For Append As #Hnd
    Print #Hnd, Addresses;
    Close #Hnd
    ShellExecute 0, "open", SenderFile, "", "", 1
  End If
 
  Exit Sub
ERR_HANDLER:
  If Hnd Then Close #Hnd
  MsgBox Err.Description
End Sub

Private Function GetSenderAddresses(Sel As Outlook.Selection) As String
  Dim b As String
  Dim obj As Object
  Dim i As Long
 
  For i = 1 To Sel.Count
    Set obj = Sel(i)
    If TypeOf obj Is Outlook.MailItem Or _
      TypeOf obj Is Outlook.MeetingItem Then
        b = b & obj.SenderEmailAddress & vbCrLf
    End If
  Next
 
  GetSenderAddresses = b End Function

---

Pls help in modifying the macro that only @domain.xx will be written in the file
In combination with this:

Auto Block Unwanted Emails with the Blacklist in a Text File (vbaexpress.com)

It could be a great solution to fighting spam!
What do you think?

UPS!
When i insert the macro to module 4 this happens

Attachment 27509

What is wrong??
http://www.vbaexpress.com/forum/imag...BJRU5ErkJggg==

.

It appears you are attempting to run a macro on a 64 bit system (Perhaps Win 10 ?) that is written for a 32 bit system .

Code:

---

Private Declare Function ShellExecute Lib "shell32.dll" Alias

---

Ahh! Exactly it is win 10 and Outlook 2019 both 64 bit
THX!

Do you also know HowTo change the code for this configuration?:yes

.
I do not know how to convert the ShellExecute to 64 bit.

Try contacting the author of the code and of course others here on the Forum.

Best wishes.

Try using the following instead

Code:

---

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr

---

Better still investigate MailWasher.

Quote:

---

Originally Posted by gmayor

Better still investigate MailWasher.

---

I have tried works good but I have 3 outlooks synct with SimpleSyn
the problem is that only one PC can have MailWasher with the Blacklist - so before getting mails in other OLs MailWasher on the 1 PC has to be executed.
I know there is a server version but this is too expensive and complicated to admin for this task.ö


[QUOTE=gmayor;405631]Try using the following instead

Code:

---

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr

---

Code is perfect
its working now

Code:

---

Private Const SenderFile As String = "C:\Users\Privat\Documents\Outlook-Dateien\BlackList\BlackList.txt"Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr


Public Sub ExportSenderAddresses()
  On Error GoTo ERR_HANDLER
  Dim Sel As Outlook.Selection
  Dim Addresses As String
  Dim File As String
  Dim Hnd As Long
 
  Set Sel = Application.ActiveExplorer.Selection
  Addresses = GetSenderAddresses(Sel)
  If Len(Addresses) Then
    Hnd = FreeFile
    Open SenderFile For Append As #Hnd
    Print #Hnd, Addresses;
    Close #Hnd
    ShellExecute 0, "open", SenderFile, "", "", 1
  End If
 
  Exit Sub
ERR_HANDLER:
  If Hnd Then Close #Hnd
  MsgBox Err.Description
End Sub


Private Function GetSenderAddresses(Sel As Outlook.Selection) As String
  Dim b As String
  Dim obj As Object
  Dim i As Long
 
  For i = 1 To Sel.Count
    Set obj = Sel(i)
    If TypeOf obj Is Outlook.MailItem Or _
      TypeOf obj Is Outlook.MeetingItem Then
        b = b & obj.SenderEmailAddress & vbCrLf
    End If
  Next
 
  GetSenderAddresses = b
  End Function

---

So now my first question
This macro adds
name@domain.xx to the list

Pls help in modifying the macro that only
@domain.xx
will be written in the file

In combination with this:

Auto Block Unwanted Emails with the Blacklist in a Text File (vbaexpress.com)

It could be a great solution to fighting spam!
What do you think?

Maybe also better to use an EXCEL file for BlackList?
What do You Think?