basproxyfrontend.bas

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

Attribute VB_Name = "basProxyFrontend"
Option Explicit

' WIN32 API declarations
Public Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'Public Declare Function FindFirstChangeNotification Lib "kernel32" Alias "FindFirstChangeNotificationA" (ByVal lpPathName As String, ByVal bWatchSubtree As Long, ByVal dwNotifyFilter As Long) As Long
'Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long


Public Type SYSTEMTIME
        wYear As Integer
        wMonth As Integer
        wDayOfWeek As Integer
        wDay As Integer
        wHour As Integer
        wMinute As Integer
        wSecond As Integer
        wMilliseconds As Integer
End Type

Type TIME_ZONE_INFORMATION
        Bias As Long
        StandardName(32) As Integer
        StandardDate As SYSTEMTIME
        StandardBias As Long
        DaylightName(32) As Integer
        DaylightDate As SYSTEMTIME
        DaylightBias As Long
End Type

Public Type NOTIFYICONDATA
        cbSize As Long
        hwnd As Long
        uID As Long
        uFlags As Long
        uCallbackMessage As Long
        hIcon As Long
        szTip As String * 64
End Type

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Public Const NIM_MODIFY = &H1
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const WM_RBUTTONUP = &H205
Public Const WM_CLOSE = &H10
Public Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1
'Public Const INFINITE = &HFFFF


Public Const CB_FINDSTRINGEXACT = &H158


Private hMainConfig As Integer      ' file handle to main config
Public strMainConfig As String     ' contents of main config file

' type for a single command
Type TCOMMAND
  strCmd As String      ' command
  strParas() As String  ' parameters
End Type

' type for one message
Type TMSG
  strSubject As String
  strFrom As String
  dDate As Date
  strHeader As String
  strBody As String
End Type
  


' enum for modules
Public Enum MODULES
  MOD_EMAIL
End Enum

' tray icon
Public TrayIcon As NOTIFYICONDATA
' server running
Public bIsRunning As Boolean
' is program currently terminating server
Public bServerTerminate As Boolean
' restart server after quitting?
Public bRestart As Boolean
' server process ID & window...
Public hServerProcess As Long
Public hwndServer As Long
' server executable (full path)
Public strServerExe As String
' server path
Public strServerDir As String
' app name, section name (for registry settings)
Public Const APPNAME = "JKProxy_Frontend"
Public Const SECTION = "settings"

Public arrBlocked() As TMSG    ' array for blocked messages



Public bStopping As Boolean, hUpdateLoop As Long
Public Sub SetupBlockedWatch()
' sets
End Sub


Public Sub ShowBlockedMessages()
' load array arrBlocked and show messages in lvBlocked
Dim i As Long, x As ListItem
Dim tmp As Long

On Error Resume Next
tmp = LBound(arrBlocked)
If Err Then Exit Sub
On Error GoTo 0


With frmMain.lvBlocked.ListItems
  .Clear
    
  ' iterate through array
  For i = LBound(arrBlocked) To UBound(arrBlocked)
    ' add listitem
    Set x = .Add
    ' set "From"
    x.Text = arrBlocked(i).strFrom
    ' set "Subject"
    x.SubItems(1) = arrBlocked(i).strSubject
    ' set "Date"
    x.SubItems(2) = arrBlocked(i).dDate
    ' save array index
    x.SubItems(3) = i
    
  Next i
  
End With
End Sub




Public Sub AddToProtocol(strText As String)
' adds some text to the event protocol
With frmMain
  .txtProtocol = .txtProtocol + CStr(Now) + " - " + strText + vbCrLf
  .txtProtocol.SelStart = Len(.txtProtocol)
End With
End Sub

Public Function ConvertDate(strDate As String) As Date
' function converts a date-string to a VB-date
' date form is:
' [Weekday,] Day MonthAsWord Year Time [bias]
' e.g. Thu, 30 Jan 2003 22:15:16 +0100

Dim arrSplit() As String, arrSplit2() As String
Dim pos As Long
Dim iYear As Long, iMonth As Long, iDay As Long, iHour As Long, iMin As Long, iSec As Long
Dim iBias As Long, iMinutes As Long

' split date
arrSplit = Split(strDate, " ")

pos = 0

' check if first part is weekday
If InStr(1, "0123456789", Mid(arrSplit(pos), 1, 1)) = 0 Then
  ' first character is NO number -> skip weekday
  pos = pos + 1
End If

' extract day
iDay = Val(arrSplit(pos))
pos = pos + 1

' extract month
Select Case LCase(arrSplit(pos))
  Case "jan": iMonth = 1
  Case "feb": iMonth = 2
  Case "mar": iMonth = 3
  Case "apr": iMonth = 4
  Case "may": iMonth = 5
  Case "jun": iMonth = 6
  Case "jul": iMonth = 7
  Case "aug": iMonth = 8
  Case "sep": iMonth = 9
  Case "oct": iMonth = 10
  Case "nov": iMonth = 11
  Case "dec": iMonth = 12
End Select
pos = pos + 1

' extract year
iYear = Val(arrSplit(pos))
pos = pos + 1

' split next parameter into hours, minutes and seconds
arrSplit2 = Split(arrSplit(pos), ":")
' extract values
iHour = arrSplit2(0)
iMin = arrSplit2(1)
iSec = arrSplit2(2)
pos = pos + 1

' bias from GMT?
iBias = 0
If pos <= UBound(arrSplit) Then
  iBias = Val(arrSplit(pos))
End If

' convert number to minutes (100 will be 60 minutes, 130 is 90 minutes)
iMinutes = -((iBias \ 100) * 60 + (iBias Mod 100))
' charge value against local bias
iMinutes = iMinutes + GetBias

' build date and return (+- bias)
ConvertDate = DateAdd("n", iMinutes, DateSerial(iYear, iMonth, iDay) + TimeSerial(iHour, iMin, iSec))
End Function

Public Sub EditRuleFile(strFile As String)
' to start editing a rule file

frmEditRules.Show , frmMain
frmEditRules.LoadFile strFile
'frmEditRules.LoadListList
End Sub

Public Function FindInList(lst As Control, strItem As String) As Integer
' searches for a certain text in a listbox and returns listindex (if found)


FindInList = SendMessage(lst.hwnd, CB_FINDSTRINGEXACT, 0, ByVal strItem)
End Function

Public Function FileExist(strFile As String) As Boolean
FileExist = (Dir(strFile) <> Empty)
End Function

Public Function GetBias() As Long
' get bias from GMT of local time zone

Dim TZ As TIME_ZONE_INFORMATION
Call GetTimeZoneInformation(TZ)

GetBias = -TZ.Bias
End Function
Public Function GetFileCont(strFile As String) As String
Dim FF As Integer

FF = FreeFile

GetFileCont = Space(FileLen(strFile))

Open strFile For Binary As #FF
  Get #FF, , GetFileCont
Close #FF
End Function

Public Sub LoadMainConfig()
' loads main config file into memory

' open file
hMainConfig = FreeFile()
Open strServerDir + "conf\main.conf" For Binary _
     Lock Write As #hMainConfig
     
' create buffer
strMainConfig = Space(FileLen(strServerDir + "conf\main.conf"))
' read data
Get #hMainConfig, , strMainConfig
' close file
Close #hMainConfig
End Sub

Public Sub NeedRestart()
frmMain.lblRestart = "Yes"
End Sub

Public Sub RemoveTrayIcon()
Shell_NotifyIcon NIM_DELETE, TrayIcon
End Sub

Public Sub LoadSettings()
Dim strTemp As String
Dim bOK As Boolean
' load internal settings
With frmMain
  ' *** server dir
  strTemp = GetSetting(APPNAME, SECTION, "serverdir")
  ' no dir or server file does not exist?
  If Trim(strTemp) = Empty Or FileExist(strTemp + "proxy.exe") = False Then
    bOK = False
    While bOK = False
       MsgBox "Please select the proxy server application in the following dialog"
       ' show dialog
      .CommonDialog1.Filter = "proxy.exe|proxy.exe"
      .CommonDialog1.ShowOpen
      ' check if correct file was selected
      If LCase(ExtractFileName(.CommonDialog1.FileName)) = "proxy.exe" Then bOK = True
    Wend
    ' now save path
    .txtServerDir = ExtractPath(.CommonDialog1.FileName)
    SaveSetting APPNAME, SECTION, "serverdir", .txtServerDir
  Else
    .txtServerDir = strTemp
  End If
  ' save server-exe full path spec.
  strServerExe = .txtServerDir + "proxy.exe"
  ' save server directory
  strServerDir = .txtServerDir
  
  ' *** spam senders
  .txtSpammers = GetSetting(APPNAME, SECTION, "spammers")
End With
End Sub


Function ExtractFileName(sFileName As Variant) As String
Dim nIdx As Integer
    For nIdx = Len(sFileName) To 1 Step -1
        If Mid$(sFileName, nIdx, 1) = "\" Then
            ExtractFileName = Mid$(sFileName, nIdx + 1)
            Exit Function
        End If
    Next nIdx

    ExtractFileName = sFileName

End Function

Function ExtractPath(sFileName) As String
Dim nIdx As Integer
    For nIdx = Len(sFileName) To 1 Step -1
       If Mid$(sFileName, nIdx, 1) = "\" Then
          ExtractPath = Mid$(sFileName, 1, nIdx)
          Exit Function
       End If
    Next nIdx
  
    ExtractPath = sFileName

End Function

Public Sub SaveConfig()
' saves all settings

' we do NOT generate a new config file but replace all settings in the existing
' config file. this method is used for keeping comments and config file structure

With frmMain

  ' *** email settings
  ' -> emailport
  ReplaceSetting strMainConfig, "emailport", .txtEmailPort
  ' -> emailtrash
  ReplaceSetting strMainConfig, "emailtrash", .txtEmailTrash
  ' -> emailrules
  ReplaceSetting strMainConfig, "emailrules", .txtEmailRules
  ' -> emailkeeptrash
  ReplaceSetting strMainConfig, "emailkeeptrash", .txtEmailKeepTrash
  ' -> emailiprules
  ReplaceSetting strMainConfig, "emailiprules", .txtEmailIPRules

End With

' close main config file
Close #hMainConfig
' delete old file
Kill "D:\MyProjects\Proxy\Debug\conf\main.conf"
' open again for output and save contents