basproxyfrontend.bas

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

hMainConfig = FreeFile()
Open "D:\MyProjects\Proxy\Debug\conf\main.conf" For Binary _
     Lock Write As #hMainConfig
Put #hMainConfig, , strMainConfig

Close #hMainConfig


End Sub

Public Sub LoadMessages(strDir As String, arrReturn() As TMSG)
' returns all messages of a directory as an array of TMSG
Dim strFile As String
Dim hOpen As Integer
Dim strBuffer As String, strBody As String, strHeader As String
Dim iFileCount As Long
Dim i As Long, pos As Long


' iterate through all files once to count them
strFile = Dir(strDir + "*.txt", vbNormal)

Do While strFile <> Empty
  iFileCount = iFileCount + 1
  
  strFile = Dir
Loop

If iFileCount = 0 Then Exit Sub

' set array dimension
ReDim arrReturn(1 To iFileCount)

' iterate trough all files to load them
strFile = Dir(strDir + "*.txt", vbNormal)
i = 1
Do While strFile <> Empty
  ' dim buffer
  strBuffer = Space(FileLen(strDir + strFile))
  ' open file and load contents
  hOpen = FreeFile
  Open strDir + strFile For Binary As #hOpen
    Get #hOpen, , strBuffer
  Close #hOpen
  
  ' seperate header and body
  pos = InStr(1, strBuffer, vbCrLf + vbCrLf)
  If pos = 0 Then pos = InStr(1, strBuffer, Chr(13) + Chr(13))
  ' if pos = 0 -> no real message - ignore!
  If pos <> 0 Then
    ' extract header and body
    strHeader = Left(strBuffer, pos - 1)
    strBody = Mid(strBuffer, pos + 4)
    ' extract subject
    arrReturn(i).strSubject = ExtractFromHeader("Subject", strHeader)
    ' extract from
    arrReturn(i).strFrom = ExtractFromHeader("From", strHeader)
    ' extract and convert date
    arrReturn(i).dDate = ConvertDate(ExtractFromHeader("Date", strHeader))
    ' save body
    arrReturn(i).strBody = strBody
    ' save header
    arrReturn(i).strHeader = strHeader
  End If

  i = i + 1
  strFile = Dir
Loop
End Sub

Public Function ExtractFromHeader(strID As String, strAll As String) As String
' extracts an element from a message header

Dim pos1 As Long, pos2 As Long
Dim bOK As Boolean

' find line
pos1 = InStr(1, strAll, Chr(10) + strID + ":", vbTextCompare)
If pos1 = 0 Then
  ' not found? maybe first line?
  If InStr(1, strAll, strID + ":", vbTextCompare) = 1 Then bOK = True
End If

If pos1 = 0 And bOK = False Then
  ' element does not exist
  ExtractFromHeader = Empty
  Exit Function
End If

' now extract
pos1 = pos1 + Len(strID) + 3
pos2 = InStr(pos1, strAll, vbCrLf, vbTextCompare)
If pos2 = 0 Then pos2 = Len(strAll) + 1

ExtractFromHeader = Mid(strAll, pos1, pos2 - pos1)
End Function


Public Sub ReplaceSetting(strSource As String, strSetting As String, strValue As String)
' replaces one setting
Dim pos As Long, pos2 As Long

' find setting position
pos = InStr(1, strSource, Chr(10) + strSetting, vbTextCompare)

' not found? -> try finding at beginning of file
If (pos = 0) Then
  If LCase(Left(strSource, Len(strSetting))) = LCase(strSetting) Then
    pos = 1
  Else
    ' setting DOES NOT exist, we need to add it
    strSource = strSource + vbCrLf + strSetting + " " + strValue
    ' exit now
    Exit Sub
  End If
Else
  pos = pos + 1
End If

' now find end-of-line
pos2 = InStr(pos, strSource, Chr(10))

If pos2 = 0 Then
  ' no CHR(10) found -> use end-of-file
  pos2 = Len(strSource)
Else
  pos2 = pos2 - 1
  ' CHR(13)?
  If Mid(strSource, pos2, 1) = Chr(13) Then pos2 = pos2 - 1
End If

' now replace line
strSource = Left(strSource, pos - 1) + strSetting + " " + strValue + Mid(strSource, pos2 + 1)

End Sub


Public Sub LoadConfig()
' loads all settings
Dim cmd As TCOMMAND


With frmMain

  ' *** email settings
  ' -> emailport
  cmd = ExtractSetting("emailport")
  .txtEmailPort = Val(cmd.strParas(1))
  ' -> emailtrash
  cmd = ExtractSetting("emailtrash")
  .txtEmailTrash = cmd.strParas(1)
  ' -> emailrules
  cmd = ExtractSetting("emailrules")
  .txtEmailRules = cmd.strParas(1)
  ' -> emailkeeptrash
  cmd = ExtractSetting("emailkeeptrash")
  .txtEmailKeepTrash = cmd.strParas(1)
  ' -> emailiprules
  cmd = ExtractSetting("emailiprules")
  .txtEmailIPRules = cmd.strParas(1)

End With
End Sub

Public Function ExtractSetting(strName As String) As TCOMMAND
Dim vreturn As TCOMMAND
Dim pos As Long, pos2 As Long
Dim pbegin As Long, pend As Long
Dim i As Long, commas As Long
Dim extract As String, ipara As Long
Dim bCR As Boolean

' set command name (again)
vreturn.strCmd = strName

' find command
pos = InStr(1, strMainConfig, Chr(10) + strName, vbTextCompare)
' if not found... maybe at the beginning of file?
If pos = 0 Then
  If Not (LCase(Left(strMainConfig, Len(strName))) = LCase(strName)) Then
    ' NO! setting does not exist
    Exit Function
  Else
    ' yes, it's at the beginning
    pos = 1
  End If
Else
  pos = pos + 1
End If

' find end
pos2 = InStr(pos, strMainConfig, Chr(10), vbTextCompare)
' if no end found -> last line
If pos2 = 0 Then
  pos2 = Len(strMainConfig)
Else
  pos2 = pos2 - 1
End If

' count commas
For i = pos To pos2
  If Mid(strMainConfig, i, 1) = "," Then commas = commas + 1
Next i
' dimension array
ReDim vreturn.strParas(1 To commas + 1)

' extract elements
pbegin = pos + Len(strName) + 1

Do
  bCR = False
  ' find end of command
  pend = InStr(pbegin, strMainConfig, ",")
  ' if no comma found or behind end-of-line -> use end-of-line
  If (pend = 0) Or (pend > pos2) Then
    pend = pos2
    ' check if there's maybe a CR (ascii 13)
    If Mid(strMainConfig, pend, 1) = Chr(13) Then
      pend = pend - 1
      bCR = True
    End If
  Else
    ' subtract one for we don't need the comma itsself
    pend = pend - 1
  End If
  
  ' extract command
  extract = Mid(strMainConfig, pbegin, pend - pbegin + 1)
  ' trim
  extract = Trim(extract)
  
  ' save in array
  ipara = ipara + 1
  vreturn.strParas(ipara) = extract
  
  ' find nxt para
  pbegin = pend + 3 + IIf(bCR, 1, 0)
  ' finisheD?
  If pbegin >= pos2 Then Exit Do
  
  
Loop

' return structure
ExtractSetting = vreturn
End Function

Public Sub SetTrayIcon()
' set an icon in the system tray (next to the clock)
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hwnd = frmMain.hwnd
TrayIcon.szTip = vbNullChar ' [DBG] ToolTip & vbNullChar
TrayIcon.hIcon = frmMain.Icon
TrayIcon.uID = vbNull
TrayIcon.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
' all messages are redirected to frmMain::Form_MouseMove
TrayIcon.uCallbackMessage = WM_MOUSEMOVE

Shell_NotifyIcon NIM_ADD, TrayIcon

End Sub




Public Sub StartServer()
' starts the proxy server

Dim x As Long

' set status and GUI
bIsRunning = True
SetGUIRunning True
' event protocol...
AddToProtocol "Starting server..."
' run server-exeutable
hServerProcess = Shell(Environ$("COMSPEC") + " /c """ + strServerExe + """>" + App.Path + "\srv_out.txt", vbHide)

Sleep 500

frmMain.tmrCheck.Enabled = True

MsgBox "Note: Tracking the server console application does not work yet. The program might show that the server crashed with an error and stopped but this is probably not correct."
End Sub


Public Sub StopServer()
' set flag
bServerTerminate = True
' terminate window
SendMessage ByVal hwndServer, ByVal WM_CLOSE, ByVal 0&, ByVal 0&
' set GUI
SetGUIRunning False
End Sub

Public Sub UpdateTrayIcon()
Shell_NotifyIcon NIM_MODIFY, TrayIcon
End Sub

Public Sub SetGUIRunning(bRunning As Boolean)
' changes the GUI (including tray) depending on if the server is running or not

With frmMain
  If bRunning = False Then
    ' labels
    .lblRunning.Caption = "Not running"
    .lblRunning.ForeColor = vbRed
    
    ' menu
    .mnuStartStop.Caption = "Start"
    
    ' command buttons
    .cmdStart.Enabled = True
    .cmdStop.Enabled = False
    .cmdRestart.Enabled = False
    
    ' tray
    TrayIcon.hIcon = .imgTray.ListImages("NOTRUNNING").ExtractIcon.Handle
    TrayIcon.szTip = TRAY_NOTRUNNING + " - " + TRAY_GETMENU + vbNullChar
    UpdateTrayIcon
    
  Else
     ' labels
    .lblRunning.Caption = "Running"
    .lblRunning.ForeColor = &H8000&
    
    ' menu
    .mnuStartStop.Caption = "Stop"
    
    ' command buttons
    .cmdStart.Enabled = False
    .cmdStop.Enabled = True
    .cmdRestart.Enabled = True
    
    ' tray
    TrayIcon.hIcon = .imgTray.ListImages("RUNNING").ExtractIcon.Handle
    TrayIcon.szTip = TRAY_RUNNING + " - " + TRAY_GETMENU + vbNullChar
    UpdateTrayIcon
  End If
End With
End Sub


Public Function TabTrim(strSource As String) As String
' removes all leading and following tabs (ASCII 9) from a string
Dim slen As Long, posStart As Long, posEnd As Long

slen = Len(strSource)

' find leading tabs
For posStart = 1 To slen
  If Mid(strSource, posStart, 1) <> vbTab Then Exit For
Next
' no tabs found?
If posStart > slen Then
  TabTrim = strSource
  Exit Function
End If

' find following tabs
posEnd = InStr(posStart, strSource, vbTab)

If posEnd = 0 Then posEnd = slen + 1

' cut string
TabTrim = Mid(strSource, posStart, posEnd - posStart)

End Function

Public Sub EditList(strList As String, owner As Object)
If FileExist(strList) = False Then Exit Sub

frmEditList.Show , owner
frmEditList.LoadFile strList

End Sub

Public Sub EditIPRules(strFile As String)
frmIPRules.Show , frmMain
frmIPRules.LoadFile strFile
End Sub