Script to rename Attachment file type

[msdd]

Hello hmail-community

first: I Like hmailserver - it serves me well and I like how versatile it is.

Now to my problem: As you know there is a lot of macro-viruses out there, so I used the bloc attachments-policy to block all Word and Excel fiels, wich works fine. My users are informed and when they need a file, I grab it from the webserver for them. This is the annoying part....

what I did:
I editet the script I found here: viewtopic.php?t=26175#p165892 to save the Attachments to another place, so that users can grab it themselves, but that isnt optimal for several reasons (the crm we use and so on...)

what I want:
I want hmailserver to just edit the name of an attachment for example from "text.docx" to "text.docx.WARNING" so that users can just edit the name of the attachment to get it open. that would be a bump high enough, to avoid accidental opening of unwanted attachments, but it would otherwise not require them to write a ticket and wait until an admin has grabbed their file for them...
Googling did not bring results I understood or could put to use...

as I am not a coder, i can merely edit, I need a script to do that... I know how to put it to work, I just have no clue how to make it happen.
can someone please help me?

Thanks for all the fish!
Martin

[jimimaseye]

Untested. Try this for a start.

Code: Select all

  Sub OnAcceptMessage(oClient, oMessage)
  
   If oClient.username <> "" then
      Dim ListOf4CharExtensions
      ListOf4CharExtensions = ".ext docx xlsx .doc"  ' Add more as necessary separated with space (must 4 characters!)
      Dim i
      For i = 0 To oMessage.Attachments.Count-1
          if InStr(1,ListOf4CharExtensions,right(oMessage.Attachments.item(i).Filename,4),1) > 0 then
              oMessage.Attachments.item(i).Filename = oMessage.Attachments.item(i).Filename & ".WARNING"
          End if
      Next
      oMessage.save
   End if
   End Sub

There are other ways to avoid this danger though. If you use Clam antivirus with Sane definitions then the various Office documents are already scanned for threats (and really quite effective) as well as other Zero hour releases. See here for installation: viewtopic.php?f=21&t=26829

Of course, there is also the policy of ensuring you turn off Automatic Macro Running in MS Office as well (always recommended) - that way even if they open a macro file it still will not do anything.

[msdd]

Hello jimimaseye,

thanks for the fas treply and sorry for my slow one...

obviously I overestimated myself - I cant get the script to run.

I put it into the EventHandlers.vbs under "Sub OnAcceptMessage(oClient, oMessage)" but nothing happens.
I also put a modified form (see below) in another sub and called it via a rule:

Action: Run Function RenameAttachments

what is it I do not get?
may it be that a virus scanner is in the way (i.e. an attachment is scanned an can therefore not be renamend, or do those things happen sequential?)


hope you, or anybody can help me with this..

thanks
Martin

Code: Select all

Sub RenameAttachments(oMessage)

Dim ListOf4CharExtensions
      ListOf4CharExtensions = ".ext docx xlsx .doc .pdf .xml"  ' Add more as necessary separated with space (must 4 characters!)
      Dim i
      For i = 0 To oMessage.Attachments.Count-1
          if InStr(1,ListOf4CharExtensions,right(oMessage.Attachments.item(i).Filename,4),1) > 0 then
              oMessage.Attachments.item(i).Filename = oMessage.Attachments.item(i).Filename & ".WARNING"
          End if
      Next
      oMessage.save
  End Sub

[jimimaseye]

Have you followed the procedure to enable scripting? https://www.hmailserver.com/documentati ... ce_scripts (bottom) ?

[msdd]

Yes I have, I also have reloaded and also Checked the syntax every time.

[EDIT]
I am more the iterative-scripting type - I need a kind of breakpoint to see if the script is even run... do I find such information in any logfile?

[EDIT]
I just found aditional infos in a log...

[msdd]

I found an error: 800A000D
losly translated: type incompatible

Is the script I posted above plausible?

[msdd]

Strange enough:

the Error message states a Line, that is not even in the EventHandler.vbs - file.

at fist ist was at line 379 allthough the file had only 377 lines,
now I took all my scripts out and have a nearly empty default file with 31 lines, the error in the Log-file points to line 33...

I am way out in the dark, somebody please bring a light...

[jimimaseye]

Dont worry, the old code wouldnt have worked anyway.

New code (tested and working).

Add unwanted extensions to the .Pattern = ".doc$|.xlsx$|.docx$" variable ensuring you finish each with dollar $ sign (and separate with pipe | )
Change the "secretpassword" (line 5) to suit:

Code: Select all

   Sub RenameAttachments(oMessage)
      Dim fso, filespec, obApp, PathStore, ListOf4CharExtensions, i, oRegExp
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set obApp = CreateObject("hMailServer.Application")
      Call obApp.Authenticate("Administrator", "secretpassword" )
      PathStore = obApp.Settings.Directories.DataDirectory
      Set oRegExp = new RegExp   
      For i = 0 To oMessage.Attachments.Count-1
         with oRegExp
          .Pattern = ".doc$|.xlsx$|.docx$"
          .IgnoreCase = True
          .Global = False
         end with
         if (oRegExp.test(oMessage.Attachments(i).Filename)) Then
            filespec = PathStore & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
            oMessage.Attachments(i).saveas(filespec)
            oMessage.Attachments(i).delete
            oMessage.Attachments.add(filespec)
            oMessage.save
            fso.DeleteFile(filespec)
         End if
      Next
      Set oRegExp = nothing
   End sub

[jimimaseye]

Dont forget the RULE to call it:

if Messagesize > 0 then

Action: Run Function RenameAttachments

(this will run against all messages. Change your IF condition to suit your needs if you dont want it against all).

[msdd]

thanks again!

I am a bit reluctant to try the new code, as it requires Authetication to the server...
Why is this needed?

It is for example not needed in this viewtopic.php?t=26175#p165892 script?

thanks
Martin

[jimimaseye]

???! What on earth do you think can happen?? If you fear someone seeing the password in the script then you have bigger problems - allowing unauthorised/untrusted people access to your mail server in the first place should be much more of a concern for you.

Its required just to obtain your datapath according to HMS install.

You really shouldnt worry about this. Really.

But if you really dont want to, then remove

Code: Select all

      Call obApp.Authenticate("Administrator", "secretpassword" )
      PathStore = obApp.Settings.Directories.DataDirectory

and replace with

Code: Select all

      PathStore = "c:\pathto\yourDATAdirectory"

[msdd]

dear jimimaseye

please, I did not mean to offend you.
I am very gratefull for your help and it seems to bring me closer to a solution.

I just established a rule for myself, to not just copy and paste code if I do not have at least an idea what it might do on my system, and putting a plaintext password in a script is always a red-light-indicator.
After your explenation, I see, that your first version is the universal approach, wich is hasle free, I thank you very much for that.

only one issue:

It still does not work.

in the log it reads:

Code: Select all

runtime error 800A000D - Types incompatible 'RenameAttachments' Line:55 Column: 0 - Code: (null)

but once again the file only has 53 lines...


Here My EventHandler.vbs file (53 lines)

Code: Select all

'   Sub OnClientConnect(oClient)
'   End Sub

'   Sub OnSMTPData(oClient, oMessage)
'   End Sub

'Sub OnAcceptMessage(oClient, oMessage)
'End Sub

'   Sub OnDeliveryStart(oMessage)
'   End Sub

'   Sub OnDeliverMessage(oMessage)
'   End Sub

'   Sub OnBackupFailed(sReason)
'   End Sub

'   Sub OnBackupCompleted()
'   End Sub

'   Sub OnError(iSeverity, iCode, sSource, sDescription)
'   End Sub

'   Sub OnDeliveryFailed(oMessage, sRecipient, sErrorMessage)
'   End Sub

'   Sub OnExternalAccountDownload(oFetchAccount, oMessage, sRemoteUID)
'   End Sub

   Sub RenameAttachments(oMessage)
      Dim fso, filespec, obApp, PathStore, ListOf4CharExtensions, i, oRegExp
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set obApp = CreateObject("hMailServer.Application")
      PathStore = "C:\Program Files (x86)\hMailServer\Data"
      Set oRegExp = new RegExp   
      For i = 0 To oMessage.Attachments.Count-1
         with oRegExp
          .Pattern = ".doc$|.xlsx$|.docx$"
          .IgnoreCase = True
          .Global = False
         end with
         if (oRegExp.test(oMessage.Attachments(i).Filename)) Then
            filespec = PathStore & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
            oMessage.Attachments(i).saveas(filespec)
            oMessage.Attachments(i).delete
            oMessage.Attachments.add(filespec)
            oMessage.save
            fso.DeleteFile(filespec)
         End if
      Next
      Set oRegExp = nothing
   End sub

[msdd]

I just did another test with your version of the script and the Password in it, it runs into the same error (just in line 56)...

[mattg]

Did you re-load the scripts after making the changes?

[msdd]

yes, I allways do.
The fact that The error now occurs in line 56 is a strong indicator, as the script with the password-line is one line longer...

[SorenR]

Ahem... You "close" oRegExp before doing the test ???

Code: Select all

      For i = 0 To oMessage.Attachments.Count-1
         with oRegExp
          .Pattern = ".doc$|.xlsx$|.docx$"
          .IgnoreCase = True
          .Global = False
         end with
         if (oRegExp.test(oMessage.Attachments(i).Filename)) Then
            filespec = PathStore & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
            oMessage.Attachments(i).saveas(filespec)
            oMessage.Attachments(i).delete
            oMessage.Attachments.add(filespec)
            oMessage.save
            fso.DeleteFile(filespec)
         End if
      Next

Should it not be...

Code: Select all

      For i = 0 To oMessage.Attachments.Count-1
         with oRegExp
            .Pattern = ".doc$|.xlsx$|.docx$"
            .IgnoreCase = True
            .Global = False
            if (.test(oMessage.Attachments(i).Filename)) Then
               filespec = PathStore & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
               oMessage.Attachments(i).saveas(filespec)
               oMessage.Attachments(i).delete
               oMessage.Attachments.add(filespec)
               oMessage.save
               fso.DeleteFile(filespec)
            End if
         end with
      Next

[jimimaseye]

Ahem... You "close" oRegExp before doing the test ???
Should it not be...

Code: Select all

      For i = 0 To oMessage.Attachments.Count-1
         with oRegExp
            .Pattern = ".doc$|.xlsx$|.docx$"
            .IgnoreCase = True
            .Global = False
            if (.test(oMessage.Attachments(i).Filename)) Then
               filespec = PathStore & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
               oMessage.Attachments(i).saveas(filespec)
               oMessage.Attachments(i).delete
               oMessage.Attachments.add(filespec)
               oMessage.save
               fso.DeleteFile(filespec)
            End if
         end with
      Next

Dunno. My version worked for me. Im no guru - I just SEARCHED and copied from others, read the documentation, googled to find a couple of answers I were unsure about, tested and it worked. (If only others were able to do the same. I must have a different internet/environment to some users).

dear jimimaseye

please, I did not mean to offend you.
I am very gratefull for your help and it seems to bring me closer to a solution.

I just established a rule for myself, to not just copy and paste code if I do not have at least an idea what it might do on my system, and putting a plaintext password in a script is always a red-light-indicator.
After your explenation, I see, that your first version is the universal approach, wich is hasle free, I thank you very much for that.

No problems to me, no offence taken at all. I was just surprised to see your objection. Not wanting to type in your password in to your eventshandlers.vbs file is going to leave you HEAVILY restricted with any scripting you may want to do with Hmailserver.

[SorenR]

My version worked for me. Im no guru - I just SEARCHED and copied from others, read the documentation, googled to find a couple of answers I were unsure about, tested and it worked. (If only others were able to do the same. I must have a different internet/environment to some users).

Try this... Changed the loop so that it does not create and destroy a RegEx object for each attachment if there are multiple attachments in the email... Oh yeah... Added comments

Code: Select all

   Sub RenameAttachments(oMessage)
      Dim oFS, strFile, strPath, i
      Set oFS = CreateObject("Scripting.FileSystemObject")

      ' Path for temporary files
      strPath = "C:\Program Files (x86)\hMailServer\Data"

      ' Create RegEx object
      With CreateObject("VBScript.RegExp")
         .Pattern = ".doc$|.xlsx$|.docx$"
         .IgnoreCase = True
         .Global = False

         ' Process attachments one by one
         For i = 0 To oMessage.Attachments.Count-1
            If (.Test(oMessage.Attachments(i).Filename)) Then

               ' Add new type to attachment file
               strFile = strPath & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"

               ' Save attachment on filesystem
               oMessage.Attachments(i).Saveas(strFile)

               ' Delete attachment from email
               oMessage.Attachments(i).Delete
               
               ' Add attachment from filesystem
               oMessage.Attachments.Add(strFile)

               ' Save changes to email
               oMessage.Save

               ' Delete file from filesystem
               oFS.DeleteFile(strFile)
            End If

         Next

      ' Destroy RegEx object (same as; Set object = Nothing)
      End With

      ' Cleanup ...
      Set oFS = Nothing

   End sub

[SorenR]

Alternative version without "With .. End With"

Code: Select all

   Sub RenameAttachments(oMessage)
      Dim oFS, oRegEx, strFile, strPath, i
      Set oFS = CreateObject("Scripting.FileSystemObject")
      Set oRegEx = CreateObject("VBScript.RegExp")
      strPath = "C:\Program Files (x86)\hMailServer\Data"
      oRegEx.Pattern = ".doc$|.xlsx$|.docx$"
      oRegEx.IgnoreCase = True
      oRegEx.Global = False
      For i = 0 To oMessage.Attachments.Count-1
         If (oRegEx.Test(oMessage.Attachments(i).Filename)) Then
            strFile = strPath & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
            oMessage.Attachments(i).Saveas(strFile)
            oMessage.Attachments(i).Delete
            oMessage.Attachments.Add(strFile)
            oMessage.Save
            oFS.DeleteFile(strFile)
         End If
      Next
      Set oRegEx = Nothing
      Set oFS = Nothing
   End sub

[msdd]

Hello Forum,

I Used your help in the matter mentioned above, and it worked nearly flawlessly for quite a while now!
BUT: lately its seems that the script is manipulating the body of the email - namely:

some emails that have extensions wich are changed to .WARNING do not have any body left after passing through the script...

That is of course not acceptable and coursed some trouble at work...

does anybody of you see a reason in the script I am using why this may occur? As stated before most of the time the script does what its soppused to do but sometimes not...

Thank you for your help!
Martin

Code: Select all

 Sub RenameAttachments(oMessage)
  Dim fso, filespec, obApp, PathStore, ListOf4CharExtensions, i, oRegExp
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set obApp = CreateObject("hMailServer.Application")
      Call obApp.Authenticate("Administrator", "notmyactualpassword" )
      PathStore = obApp.Settings.Directories.DataDirectory
      Set oRegExp = new RegExp   
      For i = 0 To oMessage.Attachments.Count-1
         with oRegExp
          .Pattern = ".doc$|.xls$|.docx$|.xlsx$|.zip$|.7z$|.pps$|.ppsx$|.ppt$|pptx$"
          .IgnoreCase = True
          .Global = False
         if (.test(oMessage.Attachments(i).Filename)) Then
               filespec = PathStore & "\" & oMessage.Attachments.item(i).Filename & ".WARNUNG"
               oMessage.Attachments(i).saveas(filespec)
               oMessage.Attachments(i).delete
               oMessage.Attachments.add(filespec)
               oMessage.save
               fso.DeleteFile(filespec)
            End if
         end with
      
      Next
      Set oRegExp = nothing
  End sub

[SorenR]

Which event call this sub ??

[msdd]

Hi,

A general rule wich matches all incoming email:

If receipient list contains "@mydomainname" run function "RenameAttachments"
(see picture below)

[SorenR]

I have done some due dilligence on your code and changed it a bit...

"obApp.Settings.Directories.DataDirectory" is changed to "obApp.Settings.Directories.TempDirectory", there is no point in using the data directory.

RegEx; You need to escape the "." with "\." to remain a dot or it will represent "any one character". Additionally ".?" means there may be a character here - or not.. Don't forget the paranthesisisis (i hate that word) grouping your criteria.

Rearranged pattern based on "(\.doc)$|(\.docx)$" == "(\.doc.?)$"

Renamed the variables (that's my "OCD" speaking)

Moved code around a bit, there is no point in repeating code unnecessarily. Also I am wondering if not the correct procedure is to process attachments LIFO in order not to fu' the order of engagement.

Anyways, as you drive it from a rule, you can test run it with a named user.

Code: Select all

Sub RenameAttachments(oMessage)
   Dim obApp, obFSO, strFile, strPath, i

   Set obApp = CreateObject("hMailServer.Application")
   Call obApp.Authenticate("Administrator", "notmyactualpassword" )
   strPath = obApp.Settings.Directories.TempDirectory

   Set obFSO = CreateObject("Scripting.FileSystemObject")

   With CreateObject("VBScript.RegExp")
      .Pattern = "(\.doc.?)$|(\.xls.?)$|(\.zip)$|(\.7z)$|(\.pps.?)$|(\.ppt.?)$"
      .IgnoreCase = True
      .Global = False

      For i = oMessage.Attachments.Count -1 To 0 Step -1

         If (.test(oMessage.Attachments(i).Filename)) Then
            strFile = strPath & "\" & oMessage.Attachments.item(i).Filename & ".WARNUNG"
            oMessage.Attachments(i).saveas(strFile)
            oMessage.Attachments(i).delete
            oMessage.Attachments.add(strFile)
            oMessage.save
            obFSO.DeleteFile(strFile)
         End if
      
      Next

   End With

End sub

[msdd]

hi,
@SorenR: thanks for your improvements, I am now running a Test with your new script for several users. Lets see if the problem arises again.

Do you see any reason why the behavior I expereienced occured in the older Script I used?

Thank you for your help
Martin

[SorenR]

Not sure but IIRC the RegEx search parms changed from initial script to problem script ...

[msdd]

Hello Again,

its been a while but the problem arose again.
It does only happen in some mails, but I fail to see a pattern. Only common thing: they all have attachments that get renamed through the script.
But not all mails with attachments lose their body...

Once again emails that got their attachment renamed properly lost all their body content. I used the script provided by SorenR from 2016/11/25

Would it be sensible to save the body content before the renaming operation and then reattach it after the operation is done?
Do you have any other approach to this?

Thanks
Martin

[jimimaseye]

You sure you are not looking at emails where they have been composed and the body is made up from an inline attachment? (And therefore removing the attachment effectively removes the body)?

My recommendation for diagnostic purposes:

Change the script so that when it has an attachment, it sends a copy of the original to a special quarantine/archive account before it modifies the email. That way, when you then find one of these 'disappearing body' messages, you can go back and see the original email to see what the pattern/cause is.

[msdd]

Hello jimimaseye,

I thought about that too, but as far as I can see this happens with text-emails as well.

I allready created a rule to place a copy of the email in an seperate folder but quickly realized, as my rule about renaming is run by every email, I just create a copy of every email - thats worthless. So I need to create the copy in the script.
Can you maybee give me a line of code to put in the script to achive that? I am not good enough at scripting and I do not want to introduce another source for errors...

Thank
Martin

[jimimaseye]

Untested. Try this:

Code: Select all

Sub RenameAttachments(oMessage)
   Dim obApp, obFSO, strFile, strPath, i

   Set obApp = CreateObject("hMailServer.Application")
   Call obApp.Authenticate("Administrator", "notmyactualpassword" )
   strPath = obApp.Settings.Directories.TempDirectory

   Set obFSO = CreateObject("Scripting.FileSystemObject")

   With CreateObject("VBScript.RegExp")
      .Pattern = "(\.doc.?)$|(\.xls.?)$|(\.zip)$|(\.7z)$|(\.pps.?)$|(\.ppt.?)$"
      .IgnoreCase = True
      .Global = False

      if oMessage.Attachments.count > 0 then
         Set newMessage = CreateObject("hMailServer.Message")
            newMessage.From = oMessage.from
            newMessage.FromAddress = oMessage.fromaddress
            newMessage.Subject = oMessage.subject
            newMessage.AddRecipient archiveaccount@yourdomain.com, archiveaccount@yourdomain.com
         if SendHTMLBody <> "" then
            newMessage.HTMLBody = oMessage.HTMLBody
         else
            newMessage.Body = oMessage.body
         End If

         For i = oMessage.Attachments.Count -1 To 0 Step -1
            newMessage.attachments.add(oMessage.Attachments.item(i).Filename)
            If (.test(oMessage.Attachments(i).Filename)) Then
               strFile = strPath & "\" & oMessage.Attachments.item(i).Filename & ".WARNUNG"
               oMessage.Attachments(i).saveas(strFile)
               oMessage.Attachments(i).delete
               oMessage.Attachments.add(strFile)
               oMessage.save
               obFSO.DeleteFile(strFile)
            End if
         Next
         newMessage.save
      End If
   End With

End sub

[ras07]

Interesting ... I've seen something that sounds similar, although it has nothing to do with a script.

When the virus checker (ClamAV) detects a virus, I have it set to delete attachments. When it does this it sometimes munges the message body.

Here's a snipped of a raw .eml file that's been munged:

Code: Select all

...(typical headers)...
X-hMailServer-LoopCount: 1

Virus found:
The attachment(s) of this message was removed since a virus was detected in at least one of them.

=0ADecember 17, 2016=0A=0A---------------------------------------=
...

Here's (approximately) what it should look like:

Code: Select all

...(typical headers)...
Content-Type: multipart/alternative; boundary=--boundary_83327305_32021b03-d9da-4d14-9ec8-ada6bcd80221
X-hMailServer-LoopCount: 1


----boundary_83327305_32021b03-d9da-4d14-9ec8-ada6bcd80221
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: quoted-printable

=0ADecember 17, 2016=0A=0A---------------------------------------=
...

(The first example is from a legit newsletter that was erroneously flagged (false positive) by ClamAV; the second snippet is from an earlier emailing of the same newsletter that didn't trigger a false-positive.)

As you can see, the content-type header is gone, as are the MIME boundary markers. Thus the email reader treats it as a plain text message, so you see mostly garbage.

I wonder if there could be a bug in the attachment deletion API that treats any MIME header as an attachment, or something like that?

Also interestingly, the original email didn't have any attachments ... even though hMS says it's deleting them ...

ras

[msdd]

thats an interesting fact.
On my hMS I also run ClamAV....

[msdd]

Hello Again,

I got the Script from jimimaseye running (there is a newNessage at the end ) caused me some headaches but I learned a lot about debugging.

Ok so now every mail with attachments is beeing copied to a dedicated post-box, but the copy has no attachments. As far as I understand the Script the copy should have the original attachments.
Is that right?

thanks
Martin

[jimimaseye]

Hello Again,

I got the Script from jimimaseye running (there is a newNessage at the end ) caused me some headaches but I learned a lot about debugging.

Sorry about that. Typo. Have now changed it in the original post.

[msdd]

hi,

thank you. Here my second question again:

Ok so now every mail with attachments is beeing copied to a dedicated post-box, but the copy has no attachments. As far as I understand the Script the copy should have the original attachments.
Is that right?

thanks
Martin

[jimimaseye]

As I said, it was untested and just a theory when I knocked it up. In hindsight my understanding of handling attachments as not sufficient and it wouldnt have worked (the filename didnt have a physical file behind it until its saved). HOWEVER..... what it does tell you is that the body of the message was distinct separately from the attachments - your original email was losing body when attachments were removed/readded whereas this one has a complete body even without the attachment.

So lets try a different approach. This one sends the ORIGINAL message to archive and creates a new message and sends it to the original intended recipient. So your archive message will be the original as it came it. Remember though that in actual fact this archive should be redundant if the newMessage (to the recipient) now gets the body and the warning attachment without problems. Anyway, see how it goes:

Code: Select all

Sub RenameAttachments(oMessage)
   Dim obApp, obFSO, strFile, strPath, i, r

   Set obApp = CreateObject("hMailServer.Application")
   Call obApp.Authenticate("Administrator", "notmyactualpassword" )
   strPath = obApp.Settings.Directories.TempDirectory

   Set obFSO = CreateObject("Scripting.FileSystemObject")

   With CreateObject("VBScript.RegExp")
      .Pattern = "(\.doc.?)$|(\.xls.?)$|(\.zip)$|(\.7z)$|(\.pps.?)$|(\.ppt.?)$"
      .IgnoreCase = True
      .Global = False

      if oMessage.Attachments.count > 0 then

         Set newMessage = CreateObject("hMailServer.Message")
            newMessage.From = oMessage.from
            newMessage.FromAddress = oMessage.fromaddress
            newMessage.Subject = oMessage.subject
         if SendHTMLBody <> "" then
            newMessage.HTMLBody = oMessage.HTMLBody
         else
            newMessage.Body = oMessage.body
         End If

         For r = oMessage.recipients.Count -1 To 0 Step -1
            newMessage.AddRecipient oMessage.Recipients(r).Address oMessage.Recipients(r).Address
         Next

         oMessage.ClearRecipients()
         oMessage.AddRecipient archiveaccount@yourdomain.com, archiveaccount@yourdomain.com

         For i = oMessage.Attachments.Count -1 To 0 Step -1
            strFile = strPath & "\" & oMessage.Attachments.item(i).Filename
            If (.test(oMessage.Attachments(i).Filename)) Then
               strFile = strFile & ".WARNUNG"
            End if
            oMessage.Attachments(i).saveas(strFile)
            newMessage.Attachments.add(strFile)
            obFSO.DeleteFile(strFile)
         Next
         oMessage.save
         newMessage.save
      End If
   End With

End sub

EDIT: just changed it to avoid crucial problem.

[msdd]

hello again.

first: Thank you very much for your help. I appreciate it a lot!
second: I Implemented your latest script, found a little error in this line:

Code: Select all

For r = oMessage.recipients.Count -1 To 0 Step -1
            newMessage.AddRecipient oMessage.Recipients(r).Address oMessage.Recipients(r).Address
         Next

corrected it to:

Code: Select all

For r = oMessage.recipients.Count -1 To 0 Step -1
            newMessage.AddRecipient oMessage.Recipients(r).Address 
            oMessage.Recipients(r).Address
         Next

but it does not do a thing...
Neither does it create a duplicate in the archive folder, nor does it rename the attachments in the mail wich goes to the original receipient.
I am clueless how to troubleshoot this.... can you please help again?

Thanks,
Martin

[jimimaseye]

My mistake.

Change the middle line that errors

Code: Select all

         For r = oMessage.recipients.Count -1 To 0 Step -1
            newMessage.AddRecipient oMessage.Recipients(r).Address oMessage.Recipients(r).Address
         Next

to

Code: Select all

        newMessage.AddRecipient oMessage.Recipients(r).Address, oMessage.Recipients(r).Address

(I was missing the comma, sorry.)


Tested and it all works for me.

[msdd]

hi,

it works as far as I can tell, and together with my ruleset its a wonderull way to completly fill a drive with all the same file very fast.
... meaning: My rule was also applied to the newly created email, which then created a new email and so on...

I tried to clear that by putting a rule on the archive account to not process any rules, but thats not working.
I also tried to create a rule for any mail with my archiveacount in the recepeint list to stop rule processing and I put that before the Attachment renaming rule but that does not work either...

my status:
1. The script seems to work
2. One email generates an endless stream of copies in the archive....

[jimimaseye]

Call the script as a function from the onacceptmessage section of eventshandler and not by a rule.

[msdd]

like so?

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)
call RenameAttachments5   
End Sub

EDIT: it is script 5 so thats no typo...

[jimimaseye]

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)
      RenameAttachments5(oMessage)
End Sub

Works for me.

Don't forget to remove the rule and change the script to a FUNCTION (and not a SUB)

[msdd]

thank you so much!
I will test it tomarrow.

Have a nice day!

[msdd]

Hello Again,

i am getting there, thank you for taking me on this journey...

I think the on accesp message does not work for me, as I get my messages from a catch-all acount from our webserver.
I Think I have to use the

Code: Select all

OnExternalAccountDownload

instead... but that does not seem to be right as nothing happens...

I also tried

Code: Select all

onDeliverMessage

but that produced a loop once again...

what am I missing?

[porcupine]

my workaround for the blank body issue, it seemed to happen consistently with html files, so here I save the attachments into a random folder, create an array of the attachment locations, delete the original attachments and then attach the renamed ones. There is also the option to add a disclaimer as an attachment using a preset file located in the Utilities folder. Thanks to those who did the original work on this.

Code: Select all

Sub WarningAttachments(oMessage)
  Dim oFS, oRegEx, strFile, strBoilerPlate, strPath, i, bNeedSave, bAddBoilerPlate, iRandom, arrAttachments()
  Set oFS = CreateObject("Scripting.FileSystemObject")
  Set oRegEx = CreateObject("VBScript.RegExp")
  'generate a random folder name
  iRandom = Int((99999)*Rnd+1)
  strPath = "C:\Program Files (x86)\hMailServer\Temp\" & iRandom
  'path to our disclaimer
  bAddBoilerPlate = True
  strBoilerPlate = "C:\Program Files (x86)\hMailServer\Addons\Utilities\Attachement_Warning_Readme.txt"
  oRegEx.Pattern = "(\.htm.?)$|(\.html.?)$"
  oRegEx.IgnoreCase = True
  oRegEx.Global = False
  bNeedSave = False
  'throws an exception when reloading scripts if we Dim with the actual ammount, use this work-around instead
  ReDim arrAttachments(oMessage.Attachments.Count)
  'rename
  For i = 0 To oMessage.Attachments.Count-1
	 If (oRegEx.Test(oMessage.Attachments(i).Filename)) Then
		'log this activity
		EventLog.Write("Attachement Renamed for " & oMessage.To & ": " & oMessage.Attachments(i).Filename)
		'create the temp folder to avoid clashes with other incoming messages
		If NOT oFS.FolderExists(strPath) Then
			oFS.CreateFolder(strPath)
		End IF
		'append the warning extension
		strFile = strPath & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
		'save the attachment
		oMessage.Attachments(i).Saveas(strFile)
		'add the path to the array
		arrAttachments(i) = strFile
		'delete the original
		oMessage.Attachments(i).Delete
		'flag that we need to save the message later
		bNeedSave = True
	 End If
  Next
  If bNeedSave Then 
	If bAddBoilerPlate Then
		'add the disclaimer
		oMessage.Attachments.Add(strBoilerPlate)
	End If
	'loop through the attachment array and re-attached to the message
	For Each strFile in arrAttachments
		If strFile <> "" Then
			oMessage.Attachments.Add(strFile)
			'cleanup
			oFS.DeleteFile(strFile)
		End If
	Next
	'save the message
	oMessage.Save
	'cleanup
	oFS.DeleteFolder(strPath)
  End If
  Set oRegEx = Nothing
  Set oFS = Nothing
End Sub

[msdd]

Hallo porcupine,

thanks for your improvements. I have not worked on this issue (blank body) for a while but it still keeps anoying me.
I looked over the script you wrote but as I wrote above my skills are limited, so despite your very well commented scriot I do not realy understand your approach.

Here are my Questions:
- Is this script used in replacement of the scripts above?
- if so: where is the part where I define whitch attachments are to be appended?
- if not: is it to add to the scripts above - Where?

please advice!

Thank Martin

[porcupine]

Hi Martin,

1, yes it replaces all other scripts, just add this line to your OnAcceptMessage "Sub":

Code: Select all

 WarningAttachments(oMessage)

2, I have added some more comments for you, to help with customizing it to your needs. Don't forget to set the path to your boilerplate file and the hmailserver temp folder

3, n/a

Same code but with more comments:

Code: Select all

Sub WarningAttachments(oMessage)
  Dim oFS, oRegEx, strFile, strBoilerPlate, strPath, i, bNeedSave, bAddBoilerPlate, iRandom, arrAttachments()
  Set oFS = CreateObject("Scripting.FileSystemObject")
  Set oRegEx = CreateObject("VBScript.RegExp")
  'generate a random folder name
  iRandom = Int((99999)*Rnd+1)
  'set the path to the hmailserver temp folder, it must end with \
  strPath = "C:\Program Files (x86)\hMailServer\Temp\" & iRandom
  'path to our disclaimer
  bAddBoilerPlate = True
  'set the path to your boilerplate message to the users
  strBoilerPlate = "C:\Program Files (x86)\hMailServer\Addons\Utilities\Attachement_Warning_Readme.txt"
  'set the extensions you want to rename, each must be in the format (\.htm.?)$ and separated with a |
  'examples:
  'oRegEx.Pattern = "(\.docx.?)$" 'renames .docx files
  'oRegEx.Pattern = "(\.htm.?)$|(\.html.?)$" 'renames both .htm and .html files
  oRegEx.Pattern = "(\.htm.?)$|(\.html.?)$"
  oRegEx.IgnoreCase = True
  oRegEx.Global = False
  bNeedSave = False
  'throws an exception when reloading scripts if we Dim with the actual ammount, use this work-around instead
  ReDim arrAttachments(oMessage.Attachments.Count)
  'rename
  For i = 0 To oMessage.Attachments.Count-1
    If (oRegEx.Test(oMessage.Attachments(i).Filename)) Then
      'log this activity
      EventLog.Write("Attachement Renamed for " & oMessage.To & ": " & oMessage.Attachments(i).Filename)
      'create the temp folder to avoid clashes with other incoming messages
      If NOT oFS.FolderExists(strPath) Then
         oFS.CreateFolder(strPath)
      End IF
      'append the warning extension, change WARNING to any other extension you would like
      strFile = strPath & "\" & oMessage.Attachments.item(i).Filename & ".WARNING"
      'save the attachment
      oMessage.Attachments(i).Saveas(strFile)
      'add the path to the array
      arrAttachments(i) = strFile
      'delete the original
      oMessage.Attachments(i).Delete
      'flag that we need to save the message later
      bNeedSave = True
    End If
  Next
  If bNeedSave Then 
   If bAddBoilerPlate Then
      'add the disclaimer
      oMessage.Attachments.Add(strBoilerPlate)
   End If
   'loop through the attachment array and re-attached to the message
   For Each strFile in arrAttachments
      If strFile <> "" Then
         oMessage.Attachments.Add(strFile)
         'cleanup
         oFS.DeleteFile(strFile)
      End If
   Next
   'save the message
   oMessage.Save
   'cleanup
   oFS.DeleteFolder(strPath)
  End If
  Set oRegEx = Nothing
  Set oFS = Nothing
End Sub

[msdd]

Hallo porcupine,

thanks for your work on that blank body problem.

firstly: you are right, theissue with the blank body does only happen with html mails. I boiled it down to html mails with embedde pictures...

secondly: even with your updated script (thanks for the comments, they help allot) it still occurs. As soon as a sender sends an email with an forbidden attachment (one that is listed under: oRegEx.Pattern = ) and this mail contains an embedded Image an email with a blank body comes out of the script.


I do not have any idea what to do now. I know too litle about the inner workings of hmailserver, but I guess that in emails with embedded pictures the body is treated like a special form of attachment which does not survive the script above (no matter which one)...

does anyone know more about this?

thanks
Martin

[porcupine]

I can confirm that the body survives with the following html file (with an embedded image), sent as an attachment when using my version of the script:

Code: Select all

<html>
<body>
Here you go!<br>
<img src="data:image/png;base64,
iVBORw0KGgoAAAANSUhEUgAAAAoAAAAKCAYAAACNMs+9AAAABGdBTUEAALGP
C/xhBQAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9YGARc5KB0XV+IA
AAAddEVYdENvbW1lbnQAQ3JlYXRlZCB3aXRoIFRoZSBHSU1Q72QlbgAAAF1J
REFUGNO9zL0NglAAxPEfdLTs4BZM4DIO4C7OwQg2JoQ9LE1exdlYvBBeZ7jq
ch9//q1uH4TLzw4d6+ErXMMcXuHWxId3KOETnnXXV6MJpcq2MLaI97CER3N0
vr4MkhoXe0rZigAAAABJRU5ErkJggg==" alt="Red dot" />
</body>
</html>

[tunis]

This is how outlook embed images.

Code: Select all

------=_NextPart_001_0014_01D3435D.9AD00560
Content-Type: text/html;
	charset="iso-8859-1"
Content-Transfer-Encoding: quoted-printable

<META HTTP-EQUIV=3D"Content-Type" CONTENT=3D"text/html; =
charset=3Diso-8859-1">
<html xmlns:v=3D"urn:schemas-microsoft-com:vml" =
...
...
<img =
width=3D64 height=3D76 id=3D"Bildobjekt_x0020_1" =
src=3D"cid:image001.png@01D3435D.2DF692B0" =
alt=3Dimage-name>
...
...
</html>
------=_NextPart_001_0014_01D3435D.9AD00560--

------=_NextPart_000_0013_01D3435D.9AD00560
Content-Type: image/png;
	name="image001.png"
Content-Transfer-Encoding: base64
Content-ID: <image001.png@01D3435D.2DF692B0>

iVBORw0KGgoAAAANSUhEUgAAAEAAAABMCAYAAADdq7GlAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJ
...
...
RK5CYII=

------=_NextPart_000_0013_01D3435D.9AD00560--

[msdd]

Hello Everyone, long time no see

but the problem is still anoying me neary every day... As I want to go on Holiday in January I need to fix this...

so here is the latest:

- The script is renaming attachments just fine.
- if an Email is an HTML-Mail with an embedded Image like the example from porcupine, everything is fine.
- if an Email is an HTML-Mail with an embedded Image like from Gmail or Outlook, the renaming works, but the body comes back as Empty

At the moment I save the email before it is dealt with by the script and if it looeses its body I manually restore it from the save... There needs to be another way...
What I can think of is saving the body temporaryly and then puting it back into the mail at the end... My coding capabilities are not suffiencent to do this, so if someone can help, please do so, its hihgly apreciated.

Thanks and Merry Christmas
Martin