5.3.x & earlier "Archiving" script (built into 5.4)

This section contains scripts that hMailServer has contributed with. hMailServer 5 is needed to use these.
Post Reply
Bill48105
Developer
Developer
Posts: 6192
Joined: 2010-04-24 23:16
Location: Michigan, USA

5.3.x & earlier "Archiving" script (built into 5.4)

Post by Bill48105 » 2012-06-29 22:18

**********************************************************
For info on using the BUILT-IN archiving feature in 5.4 read this:
http://www.hmailserver.com/forum/viewto ... 02#p123402

**********************************************************

A few people have asked for the script version of hmailserver 5.4's "Archiving" feature that makes copies of all mail in/out & stores in a useful directory structure similar to hmail's Data tree. This script was the inspiration for hmail 5.4's Archiving. The original was made by rolaids0 & is posted here with permission

(This is an update of the original version which was later tweaked/enhanced & if I recall there were minor issues but it has been 2 years so I don't recall off hand ATM. I'll work on posting a copy of the newest one but this is what is available for now. )

EDIT: I recall now. One issue with the original was if there was more than 1 recipient but this one is a newer one which looped thru recipients so each got a copy. Understand with this script that means a LOT of hard drive & cpu use with many recipients especially for bigger emails. 5.4's built-in archiving has hard-link support so actual copies are not needed & saves considerably on space & cpu usage.

Code: Select all

' Original by rolaids0 - Update: 5/13/2010
' Set StrSave path to where you want Archive tree.
' Edit "Administrator","**PASSWORD**" below with your hmail admin user/pass

Dim StrSave: StrSave = "C:\Archive"
Dim DebugLog: DebugLog = False

'provides some archival facilites.
Sub OnAcceptMessage(oClient, oMessage)
	Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
	Dim HMA: Set HMA = CreateObject("hMailServer.Application")

	'auth the connection
	Call HMA.Authenticate("Administrator","**PASSWORD**")
	HMA.Connect

	'get the domains
	Dim oDomains: Set oDomains = HMA.Domains

	'open the log
	If DebugLog = True Then	Dim FSOStream: Set FSOStream = FSO.OpenTextFile(StrSave & "\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & ".log",8,True)

	If DebugLog = True Then	
		FSOStream.WriteLine Now & " Count: " & oMessage.Recipients.Count
		FSOStream.WriteLine Now & " Processing: " & oMessage.FileName
	End If

	Dim I, J
	J = False
	For I = 0 to oMessage.Recipients.Count - 1
		'test to see if the user is local or not
		If oMessage.Recipients(I).IsLocalUser = True Then
			If DebugLog = True Then	FSOStream.WriteLine Now & " For Local User:" & oMessage.Recipients(I).Address
			Call FSO.CopyFile(oMessage.FileName,GenerateFolderTree(oMessage.Recipients(I).Address,FSO) & FSO.GetFileName(oMessage.FileName))
			If oMessage.Recipients(I).Address = oMessage.FromAddress Then J = True
		Else
			If J = False Then
				If DebugLog = True Then	FSOStream.WriteLine Now & " From Local User:" & oMessage.FromAddress
				Call FSO.CopyFile(oMessage.FileName,GenerateFolderTree(oMessage.FromAddress,FSO) & FSO.GetFileName(oMessage.FileName))
				J = True
			End If
		End If
	Next

	If DebugLog = True Then	
		FSOStream.WriteLine Now & " Done!"
		'close the log
		FSOStream.Close
	End If

	'set the result=0, deliver
	Result.Value=0

	'clean up
	Set FSO = Nothing
	Set FSOStream = Nothing
	Set HMA = Nothing
	Set oDomains = Nothing
End Sub

'this function will create a tree based upon the email address given
Private Function GenerateFolderTree(ByRef StrEmail, ByRef oFSO)
	Dim UserName: UserName = Mid(StrEmail,1,InStr(StrEmail,"@") - 1)
	Dim UserDom: UserDom = Mid(StrEmail,InStr(StrEmail,"@") + 1, Len(StrEmail))

	'See if the folder exists...
	If oFSO.FolderExists(StrSave & "\" & UserDom & "\" & UserName) = True Then
		GenerateFolderTree = StrSave & "\" & UserDom & "\" & UserName & "\"
		'exists
		Exit Function
	End If

	'does not exist... lets build the path
	'split the path parts up
	Dim ArrPath: ArrPath = Split(StrSave & "\" & UserDom & "\" & UserName, "\")
	Dim TempPath
	Dim I

	'the first one is the drive, it must exist, skip it and check the others
	TempPath = ArrPath(0) & "\"

	For I = 1 to UBound(ArrPath)
		TempPath = TempPath & ArrPath(I) & "\"
	
		'check to see if the folder exists...	
		If oFSO.FolderExists(TempPath) = False Then
			'create the folder
			oFSO.CreateFolder(TempPath)
		End If
	Next

	'return the new path
	GenerateFolderTree = TempPath
	
End Function
hMailServer build LIVE on my servers: 5.4-B2014050402
#hmailserver on FreeNode IRC https://webchat.freenode.net/?channels=#hmailserver
*** ABSENT FROM hMail! Those in IRC know how to find me if urgent. ***

Post Reply