Medya Blue

Windows Server Family Developer Center

  • hMail Smtp Limit 2010

    Hmail Server da günlük mail gönderimine kota koymak için hazırlanmış bir script.

    1Vbs Script

    '------------------------------------------------------------------
    ' Global variables and settings
    '------------------------------------------------------------------
    Public obApp
    Public domain_buffer
    Public Const ipslocalhost = "0.0.0.0" 'separated by #
    Public Const user = "Administrator"
    Public Const pw = "sifre_girilmeli"

    Public Const outgoingstore = "E:\hMailServer\Events\Outgoing.txt"
    Public Const limit_file = "E:\hMailServer\Events\Limit.txt"
    Public Const date_file = "E:\hMailServer\Events\Limit_Date.txt"
    Public Const log_path = "E:\hMailServer\Logs\"

    Public Const user_limit = 250
    Public Const warning_factor = 0.9

    Public Const msg_from = "Host Firma Adı "
    Public Const msg_fromaddress = "firma@emailadresi.com"
    '------------------------------------------------------------------
    ' Hmailserver Eventhandlers
    '------------------------------------------------------------------
    Sub OnAcceptMessage(oClient, oMessage)
    Result.Value = 0
    Set obApp = CreateObject("hMailServer.Application")
    Call obApp.Authenticate(user, pw)
    If has_client_authenticated(oClient) Then
    write_log ("Dogrulandi " & oCLient.username & ", Client " & oClient.IPAddress)
    if not check_limit(oClient, oMessage) Then
    Result.Message = "Mailserver SMTP outgoing limits."
    Result.Value = 2
    End if
    End if
    End Sub
    '------------------------------------------------------------------
    ' SMTP limit outgoing emails of domain and user
    '------------------------------------------------------------------
    function check_limit(oClient, oMessage)
    check_limit = true
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim fs , f
    Set fs = CreateObject("scripting.filesystemobject")
    Dim idt
    Dim content
    Dim ln
    Dim arr
    Dim usern
    Dim usernadd
    Dim usernnr
    Dim user_max
    Dim reason
    Dim rcptscnt
    Dim dayamounts(200)
    For i = 0 To 200
    dayamounts(i) = 0
    Next
    Dim pos
    Dim minday
    minday = 999999
    If oclient.username <> "" Then
    If instr(1,oclient.username,"@") = 0 Then
    usern = oclient.username & "@" & obApp.Settings.DefaultDomain
    Else
    usern = oclient.username
    End If
    ElseIf is_local_domain(omessage.fromaddress) then
    usern = omessage.fromaddress
    Else
    usern = "local"
    End If
    content = "# " & get_date() & " SMTP outgoing storage" & nl & nl
    usernadd = true
    usernnr = 1
    user_max = user_limit
    idt = CLng(Date())
    rcptscnt = omessage.Recipients.count
    write_log("Sayac " & rcptscnt)
    write_log(omessage.to)
    '------------------------------------------------------------------
    If fs.FileExists(limit_file) Then
    Set f = fs.OpenTextFile(limit_file, ForReading)
    Do While Not f.AtEndOfStream
    ln = f.ReadLine
    If ln <> "" And Mid(ln,1,1) <> "#" And Len(ln) > 3 Then
    arr = Split(ln,Chr(9))
    If UBound(arr) = 1 Then
    If arr(0) = usern Then
    user_max = CLng(arr(1))
    write_log ("Limit " & ln)
    End If
    Else
    write_log ("Limit Okunamadi " & Mid(ln,1,25))
    End If
    ElseIf Len(ln) > 5 And f.Line > 4 + 1 Then
    write_log ("Limit Satiri Atlandi " & Mid(ln,1,25))
    End If
    Loop
    Else
    Set f = fs.OpenTextFile(limit_file, ForWriting, true)
    f.Write("# Outgoing limitation exceptions tab / Chr(9) separated" & nl)
    f.Write("# Examples (without # at the beginning)" & nl)
    f.Write("# @yourdomain.com 10000" & nl)
    f.Write("# address@yourdomain.com 5000" & nl & nl)
    f.Close
    End If
    '------------------------------------------------------------------
    If fs.FileExists(outgoingstore) Then
    Set f = fs.OpenTextFile(outgoingstore, ForReading)
    Do While Not f.AtEndOfStream
    ln = f.ReadLine
    If ln <> "" And Mid(ln,1,1) <> "#" And Len(ln) > 5 Then
    arr = Split(ln," ")
    If UBound(arr) > 1 Then
    If minday > CLng(arr(0)) Then
    minday = CLng(arr(0))
    End If
    End If
    If UBound(arr) = 2 Or UBound(arr) = 3 Then
    If CLng(arr(0)) = idt And arr(2) = usern Then
    usernnr = CLng(arr(1)) + rcptscnt
    usernadd = False
    write_log ("Eklendi " & ln)
    If usernnr > user_max Then

    If UBound(arr) = 3 Then
    If arr(3) = "X" then
    write_log ("Durduruldu")
    Else
    write_log ("Reddedildi-1")
    out_send_message oClient, oMessage, false, usernnr, user_max
    End if
    Else
    write_log ("Reddedildi-2")
    out_send_message oClient, oMessage, false, usernnr, user_max
    End If
    content = content & arr(0) & " " & usernnr & " " & arr(2) & " X" & nl

    ElseIf usernnr > user_max * warning_factor then
    If UBound(arr) = 3 Then
    If arr(3) = "W" then
    write_log ("Limit Doldu")
    Else
    write_log ("Uyarı Gonderildi")
    out_send_message oClient, oMessage, true, usernnr, user_max
    End if
    Else
    write_log ("Limit Dolmak Uzere")
    out_send_message oClient, oMessage, true, usernnr, user_max
    End If
    content = content & arr(0) & " " & usernnr & " " & arr(2) & " W" & nl
    Else
    content = content & arr(0) & " " & usernnr & " " & arr(2) & nl
    End If
    Else
    content = content & arr(0) & " " & arr(1) & " " & arr(2) & nl
    End If

    If Mid(arr(2),1,1) <> "@" Then
    pos = idt - CLng(arr(0))
    dayamounts(pos) = dayamounts(pos) + CLng(arr(1))
    End If

    Else
    write_log ("Basarisiz-2 " & Mid(ln,1,25))
    End If

    ElseIf Len(ln) > 5 And f.Line > 1 + 1 then
    write_log ("Satir Atlandi-1 " & Mid(ln,1,25))
    End If

    Loop
    f.Close
    If usernadd Then
    content = content & idt & " " & usernnr & " " & usern & nl
    End If
    Set f = fs.OpenTextFile(outgoingstore, ForWriting, true)
    f.Write(content)
    f.Close
    Else
    content = content & idt & " " & usernnr & " " & usern & nl
    Set f = fs.OpenTextFile(outgoingstore, ForWriting, true)
    f.Write(content)
    f.Close
    End If
    If user_max < usernnr Then
    check_limit = false
    write_log("ERR")
    Else
    write_log("OK")
    End If
    End function

    Sub out_send_message(oClient, oMessage, iswarning, nr, max)
    Dim txt
    Dim tmp
    If oclient.username <> "" then
    tmp = oclient.username
    Else
    tmp = oMessage.FromAddress
    End If
    If iswarning Then
    txt = "SAYIN " & tmp & nl & nl
    txt = txt & "HESAP GONDERIM LIMITI DOLMAK UZERE." & nl & nl
    txt = txt & "GONDERILEN : " & nr & nl
    txt = txt & "LIMIT : " & max & nl & nl

    Set nMessage = CreateObject("hMailServer.Message")
    nMessage.From = msg_from
    nMessage.FromAddress = msg_fromaddress
    nMessage.AddRecipient tmp, tmp
    nMessage.Subject = "UYARI : MAIL GONDERIM LIMITI DOLMAK UZERE"
    nMessage.Body = txt
    nMessage.Save
    Else
    txt = "SAYIN " & tmp & nl & nl
    txt = txt & "HESAP GONDERIM LIMITI DOLDU." & nl & nl
    txt = txt & "GONDERILEN : " & nr & nl
    txt = txt & "LIMIT : " & max & nl & nl

    Set nMessage = CreateObject("hMailServer.Message")
    nMessage.From = msg_from
    nMessage.FromAddress = msg_fromaddress
    nMessage.AddRecipient tmp, tmp
    nMessage.Subject = "UYARI : MAIL GONDERIM DURDURURLDU"
    nMessage.Body = txt
    nMessage.Save
    End If
    End Sub
    '------------------------------------------------------------------
    ' General functions of all scripts
    '------------------------------------------------------------------
    Function get_date
    Dim tmp
    Dim erg
    tmp = Year(Date)
    erg = CStr(tmp)
    If Month(Date) < 10 Then
    tmp = "0" & Month(Date)
    Else
    tmp = Month(Date)
    End If
    erg = erg & "-" & tmp

    If day(Date) < 10 Then
    tmp = "0" & day(Date)
    Else
    tmp = day(Date)
    End If
    erg = erg & "-" & tmp
    get_date = erg
    End Function


    Function chk_date
    Dim fso
    Set fso = CreateObject("scripting.filesystemobject")
    Dim old_date
    Dim new_date
    Dim hedef
    new_date = get_date()
    If fso.FileExists(date_file) Then
    Set fs = fso.OpenTextFile(date_file)
    old_date = fs.ReadLine
    Set fs = Nothing
    If old_date <> new_date Then
    Set fs = fso.CreateTextFile(date_file)
    fs.WriteLine new_date
    Set fs = Nothing
    hedef = log_path & "Outgoing_" & get_date() & ".txt"
    fso.MoveFile outgoingstore, hedef
    End If
    else
    Set fs = fso.CreateTextFile(date_file)
    fs.WriteLine new_date
    Set fs = Nothing
    end if
    Set fso = Nothing
    End Function

    Sub write_log(txt)
    chk_date()
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim fs
    Dim f
    Set fs = CreateObject("scripting.filesystemobject")
    Dim fn
    Dim tmp
    fn = log_path & "Report_" & get_date & ".log"
    Set f = fs.opentextfile(fn, ForAppending, true)
    tmp = """" & FormatDateTime(Date + time,0) & """" & Chr(9) & """" & txt & """" & nl
    if txt="OK" or txt="ERR" then
    tmp = tmp & nl
    end if
    f.Write(tmp)
    f.Close
    End Sub

    Function nl
    nl = Chr(13) & Chr(10)
    End function

    Function is_local_domain(domain_or_email)
    is_local_domain = False
    Dim domain
    Dim doms
    Dim alss
    Dim i
    Dim j
    If InStr(1," " & domain_or_email,"@") > 0 Then
    domain = Mid(domain_or_email, InStr(1,domain_or_email,"@") + 1)
    Else
    domain = domain_or_email
    End If
    If domain_buffer = "" then
    i = 0
    Set doms = obapp.Domains
    Do While i <= doms.Count - 1
    Set dom = doms.Item(i)
    domain_buffer = domain_buffer & "#" & dom.Name
    j = 0
    Set alss = dom.DomainAliases
    Do While j <= alss.Count - 1
    Set als = alss.item(j)
    domain_buffer = domain_buffer & "#" & als.AliasName
    j = j + 1
    Loop
    i = i + 1
    Loop
    End If
    If InStr(1, " " & domain_buffer, domain) > 0 Then
    is_local_domain = True
    End If
    End Function

    Function has_client_authenticated(oclient)
    has_client_authenticated = false
    If oCLient.username <> "" Or InStr(1," " & ipslocalhost, oClient.IPAddress) > 0 Then
    has_client_authenticated = true
    End if
    End Function

    2Limit.txt

    # Outgoing limitation exceptions tab / chr(9) separated
    # Examples (without # at the beginning)
    # @yourdomain.com 10000
    # address@yourdomain.com 5000

    arsiv@deneme.com 1500
    bilgi@deneme.com 1500

    3Outgoing.txt

    # 2010-02-28 SMTP outgoing storage

    40237 2 arsiv@deneme.com
    40237 4302 bilgi@deneme.com

    4Limit_date.txt

    2010-02-28

    Yüklemeler
    hMail Smtp Limit 2010
    Hmail Limit Smtp 2010
    rar
    Tasarım Deep Design Group
    Copyright ® 2013 MEDYA BLUE