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

[Witzker]

Hi
I found this macro
Export Email Addresses - VBOffice

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

ERROR ROT.jpg

What is wrong??

[Logit]

.

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 .

Private Declare Function ShellExecute Lib "shell32.dll" Alias 

[Witzker]

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

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

[Logit]

.
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.

[gmayor]

Try using the following instead

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.

[Witzker]

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

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

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?

[Witzker]

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