frmeditrules.frm

JK Proxy Project - Version 0.1 ------------------------------ This was going to be a proxy serve

         Top             =   3120
         Width           =   9135
      End
   End
End
Attribute VB_Name = "frmEditRules"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private strOpenFile As String

Private Enum RULETYPE
  RT_COMMENT
  RT_RULE
  RT_LOADLIST
End Enum

' a single rule (or loadlist)
Private Type RULE
  rtype As RULETYPE
  para() As String
End Type

Private arrRules() As RULE  ' array of rules
Private iRulesSize As Long  ' array elements
Private cRules As Long      ' number of rules in array
Private iCurRule As Long    ' rule which is currently selected
  
Public Sub AddEntry(iType As Long)
' create "empty" rule
Dim x As ListItem, newrule As RULE

Select Case iType
  Case RT_COMMENT
    newrule.rtype = RT_COMMENT
    ReDim newrule.para(0)
  
  Case RT_RULE
    newrule.rtype = RT_RULE
    ReDim newrule.para(5)
    newrule.para(0) = "body"
    newrule.para(2) = "contains"
    newrule.para(3) = "I"
    newrule.para(4) = """"""
    newrule.para(5) = "isspam"
    
  Case RT_LOADLIST
    newrule.rtype = RT_LOADLIST
    ReDim newrule.para(1)
    
End Select

' now add this rule to array
cRules = cRules + 1
ReDim Preserve arrRules(1 To cRules)
arrRules(cRules) = newrule
' add to listview
If lvRules.SelectedItem Is Nothing Then
  Set x = lvRules.ListItems.Add
Else
  Set x = lvRules.ListItems.Add(lvRules.SelectedItem.Index + 1)
End If
x.Text = GetRuleSentence(newrule)
x.SubItems(1) = CStr(cRules)
' select item
x.Selected = True
lvRules_ItemClick x

End Sub


Private Function BuildRule() As RULE
' builds a RULE struct from the current GUI rule settings...
Dim retval As RULE


If arrRules(iCurRule).rtype = RT_RULE Then
  ' *** this is a RULE
  retval.rtype = RT_RULE
  
  If cmbRuleType.ListIndex <> 3 Then
    ' text comparision rule
    ReDim retval.para(0 To 5)
    
    ' type of rule
    Select Case cmbRuleType.ListIndex
      Case 0: retval.para(0) = "header"
      Case 1: retval.para(0) = "body"
      Case 2: retval.para(0) = "email"
    End Select
    ' set header element?
    If cmbRuleType.ListIndex = 0 Then retval.para(1) = cmbHeaderElement.Text
    ' type of comparison
    Select Case cmbCompareType.ListIndex
      Case 0: retval.para(2) = "contains"
      Case 1: retval.para(2) = "notcontains"
      Case 2: retval.para(2) = "equals"
      Case 3: retval.para(2) = "notequals"
      Case 4: retval.para(2) = "pattern"
      Case 5: retval.para(2) = "notpattern"
    End Select
    ' case-sensitive?
    retval.para(3) = IIf(chkSensitive.Value = 1, "C", "I")
    ' compare against what?
    If optCompare(0).Value = True Then
      ' string
      retval.para(4) = """" + txtCompare.Text + """"
    Else
      ' list
      retval.para(4) = "@" + cmbCompare.Text
    End If
    ' action?
    If optAction(0).Value = True Then
      ' block
      retval.para(5) = "isspam"
    Else
      ' pass
      retval.para(5) = "pass"
    End If
    
  Else
    ' size rule
    ReDim retval.para(0 To 3)
    retval.para(0) = "size"
    ' greater than ? less than ?
    retval.para(1) = IIf(cmbBigSmall.ListIndex = 0, "<", ">")
    ' bytes
    retval.para(2) = CStr(Val(txtBytes))
    ' action?
    If optAction(0).Value = True Then
      ' block
      retval.para(3) = "isspam"
    Else
      ' pass
      retval.para(3) = "pass"
    End If
    
    
  End If
  
ElseIf arrRules(iCurRule).rtype = RT_COMMENT Then
  ' comment
  ReDim retval.para(0)
  retval.rtype = RT_COMMENT
  retval.para(0) = txtComment

ElseIf arrRules(iCurRule).rtype = RT_LOADLIST Then
  ' loadlist
  ReDim retval.para(0 To 1)
  retval.rtype = RT_LOADLIST
  retval.para(0) = txtListName
  retval.para(1) = txtListFile
End If

BuildRule = retval

End Function


Private Sub ClrEdit()
' clears rule editing pane
cmbRuleType.ListIndex = -1
End Sub

Public Sub LoadFile(strFile As String)
' loads a rule file
Dim strLine As String
Dim FF As Integer
Dim pos1 As Long
Dim i As Long

strOpenFile = strFile

' redim array
ReDim arrRules(1 To 10)
iRulesSize = 10

' open file
FF = FreeFile
Open strFile For Input As #FF
  ' read line by line
  While Not EOF(FF)
    ' increase counter
    cRules = cRules + 1
    ' need to enlarge array?
    If cRules > iRulesSize Then
      iRulesSize = iRulesSize + 10
      ReDim Preserve arrRules(1 To iRulesSize)
    End If
  
    Line Input #FF, strLine
    ' trim
    strLine = Trim(strLine)
    
    If (strLine <> Empty) Then
      
      ' comment?
      If Left(strLine, 1) = "#" Then
        arrRules(cRules).rtype = RT_COMMENT
      ElseIf LCase(Left(strLine, 4) = "rule") Then
      ' rule?
        arrRules(cRules).rtype = RT_RULE
      ElseIf LCase(Left(strLine, 8) = "loadlist") Then
      ' loadlist?
        arrRules(cRules).rtype = RT_LOADLIST
      End If
      
      ' find parameters, split and store in array
      If arrRules(cRules).rtype <> RT_COMMENT Then
        pos1 = InStr(1, strLine, " ")
        arrRules(cRules).para = Split(Mid(strLine, pos1 + 1), ",")
        
        ' now remove all leading and following tabs and spaces
        For i = LBound(arrRules(cRules).para) To UBound(arrRules(cRules).para)
          arrRules(cRules).para(i) = Trim(TabTrim(arrRules(cRules).para(i)))
        Next i
      Else
        ' put complete line into first parameter
        ReDim arrRules(cRules).para(0)
        arrRules(cRules).para(0) = Mid(strLine, 2)
      End If
      
    Else
      ' no real rule, decrease counter
      cRules = cRules - 1
    End If
  Wend
Close #FF

' now show list
ShowList
End Sub

Private Function GetRuleSentence(r As RULE) As String
' this is the "magical" function which turns a RULE struct into a
' written sentence of natural language

Dim strRet As String
Dim bSize As Boolean
Dim temp As Long
Dim bStrComp As Boolean

' switch between base types
Select Case r.rtype
  Case RT_COMMENT
    ' a simple comment
    strRet = "[Comment]: " + r.para(0)
  Case RT_LOADLIST
    ' load a list
    strRet = "[Loadlist]: Load list of words from '" + r.para(1) + "' and save as '" + r.para(0) + "'"
  
  Case RT_RULE
    ' beginning
    strRet = "[Rule]: "
    ' size rule?
    bSize = (LCase(r.para(0)) = "size")
    ' set position of 'isspam'/'pass'
    temp = IIf(bSize, 3, 5)
  
    '1. block or pass?
    If LCase(r.para(temp)) = "pass" Then
      strRet = strRet + "Pass"
    ElseIf LCase(r.para(temp)) = "isspam" Then
      strRet = strRet + "Block"
    End If
    strRet = strRet + " messages where "
    
    ' header? size? body? email?
    Select Case LCase(r.para(0))
      Case "header"
        ' add string and header element
        strRet = strRet + "header element '" + r.para(1) + "' "
        ' string comparison rule!
        bStrComp = True
      Case "body"
        strRet = strRet + "body "
        ' string comparison rule!
        bStrComp = True
      Case "email"
        strRet = strRet + "sender's email address "
        ' string comparison rule!
        bStrComp = True
      Case "size"
        strRet = strRet + "size "
        ' no comparison rule!
        bStrComp = False
        
    End Select
    
    ' now process rest of this rule depending on if it
    ' is a string comparison rule or not
    If bStrComp = True Then
      ' type of comparison
      Select Case LCase(r.para(2))
        Case "contains": strRet = strRet + "contains "
        Case "notcontains": strRet = strRet + "does not contain "
        Case "equals": strRet = strRet + "equals "
        Case "notequals": strRet = strRet + "does not equal "
        Case "pattern": strRet = strRet + "pattern-matches "
        Case "notpattern": strRet = strRet + "does not pattern-match "
      End Select
      ' compare against what?
      If Left(r.para(4), 1) = "@" Then
        ' list
        strRet = strRet + "a word in list '" + Mid(r.para(4), 2) + "' "
      Else
        strRet = strRet + r.para(4) + " "
      End If
      
      ' case sensitive?
      If LCase(Left(r.para(3), 1)) = "c" Then
        strRet = strRet + "(case-sensitive)"
      Else
        strRet = strRet + "(case-insensitive)"
      End If
    Else
      ' this is a size-rule
      strRet = strRet + "is "
      ' greater or less?
      If r.para(1) = "<" Then
        strRet = strRet + "less than "
      Else
        strRet = strRet + "greater than "
      End If
      ' which size?
      strRet = strRet + CStr(Val(r.para(2))) + " bytes"
    End If

  
End Select

' return value
GetRuleSentence = strRet

End Function

Public Sub LoadListList()
' fills cmbCompare with a list of all loaded lists
Dim i As Long


With cmbCompare
  .Clear
  
  For i = LBound(arrRules) To iCurRule
    ' if list then add to cmbCompare
    If LCase(arrRules(i).rtype) = RT_LOADLIST Then
      cmbCompare.AddItem arrRules(i).para(0)
    End If
  Next i
End With
End Sub

Private Sub LoadRule(Index As Long)
Dim currule As RULE
Dim iSearch As Integer

currule = arrRules(Index)

' first of all hide all input panes
picRule.Visible = False
picComment.Visible = False
picLoadList.Visible = False

' rule? comment?

If currule.rtype = RT_RULE Then
  ' rule
  picRule.Visible = True
  ' type
  Select Case LCase(currule.para(0))
    Case "header": cmbRuleType.ListIndex = 0
    Case "body": cmbRuleType.ListIndex = 1
    Case "email": cmbRuleType.ListIndex = 2
    Case "size": cmbRuleType.ListIndex = 3
  End Select
  ' header element?
  If cmbRuleType.ListIndex = 0 Then
    cmbHeaderElement.Text = currule.para(1)
  End If

  ' with text comparison?
  If cmbRuleType.ListIndex <> 3 Then
    ' yes
    
    ' type of comparison
    Select Case LCase(arrRules(iCurRule).para(2))
      Case "contains": cmbCompareType.ListIndex = 0
      Case "notcontains": cmbCompareType.ListIndex = 1
      Case "equals": cmbCompareType.ListIndex = 2
      Case "notequals": cmbCompareType.ListIndex = 3
      Case "pattern": cmbCompareType.ListIndex = 4
      Case "notpattern": cmbCompareType.ListIndex = 5
    End Select
    ' compare against what?
    If Left(arrRules(iCurRule).para(4), 1) <> "@" Then
      ' word, cut off quotes
      optCompare(0).Value = True
      txtCompare = Mid(arrRules(iCurRule).para(4), 2)
      txtCompare = Left(txtCompare, Len(txtCompare) - 1)
    Else
      ' list
      optCompare(1).Value = True
      ' find item
      iSearch = FindInList(cmbCompare, Mid(arrRules(iCurRule).para(4), 2))
      ' not found?
      If iSearch < 0 Then