by Loai (1 Submission)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Tue 5th February 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Internet- Connect and hack to others PC's
VBcoders
'If the command line has a switch, then
'use english messages
If Command$ <> "" Then
Language = 300
ChangeMenus
Else
Language = 200
End If
cmdAceptar.Caption = LoadResString(Language + 2)
cmdOpenEmail.Caption = LoadResString(Language + 3)
lblTitle(0).Caption = LoadResString(Language + 80)
lblTitle(1).Caption = LoadResString(Language + 81)
ShowProgramInTray 'self explanatory
App.TaskVisible = False
LeerConfiguracion 'read program settings
SetListTabStops lstMsgHead.hWnd
mnuOptionsCheckNow_Click 'check now
End Sub
'Delete the systray icon
Private Sub Form_Unload(Cancel As Integer)
result = Shell_NotifyIconA(NIM_DELETE, NI) 'removes the icon from the tray
End Sub
'Program about
Private Sub mnuOptionsAbout_Click()
frmAbout.Show 1
End Sub
'Program exit
Private Sub mnuOptionsCerrar_Click()
Unload Me
End Sub
'Configure the program
Private Sub mnuOptionsConfigurar_Click()
frmConfigurar.Show 1
'
TimeToCheck = Val(Interval)
End Sub
'Go for it!!
Private Sub mnuOptionsCheckNow_Click()
Dim Respuesta As String
Dim cantmensajes As String
On Error GoTo errsock
wsock.RemoteHost = pop3Host
wsock.RemotePort = POP3Port
wsock.LocalPort = 0
'if localport <> 0 then I must wait 4 minutes
'for reuse the socket. A design behavior of the control
wsock.Connect
If Not WaitFor("+", Respuesta) Then
If NotifyCommErrors Then MsgBox LoadResString(Language + 4), vbCritical
ShowIconInTray 30, LoadResString(Language + 5)
wsock.Close
Exit Sub
End If
wsock.SendData "USER " & pop3User + vbCrLf
If Not WaitFor("+", Respuesta) Then
If NotifyCommErrors Then MsgBox LoadResString(Language + 6), vbCritical
ShowIconInTray 30, LoadResString(Language + 7)
wsock.Close
Exit Sub
End If
wsock.SendData "PASS " & pop3Passwd + vbCrLf
If Not WaitFor("+", Respuesta) Then
If NotifyCommErrors Then MsgBox LoadResString(Language + 8), vbCritical
ShowIconInTray 30, LoadResString(Language + 9)
wsock.Close
Exit Sub
End If
wsock.SendData "STAT" + vbCrLf
If Not WaitFor("+", Respuesta) Then
If NotifyCommErrors Then MsgBox LoadResString(Language + 10), vbCritical
ShowIconInTray 30, LoadResString(Language + 11)
wsock.Close
Exit Sub
End If
cantmensajes = Mid$(Respuesta, 5, InStr(5, Respuesta, " ", vbTextCompare) - 5)
lblMsg(0).Caption = LoadResString(Language + 12) + " " + cantmensajes + " " + LoadResString(Language + 13)
imgNewMail.Picture = LoadResPicture(IIf(cantmensajes > 0, 80, 90), vbResIcon)
If Val(cantmensajes) > 0 Then
If showmsgHeaders Then
Msgs = ParseMail(Val(cantmensajes))
End If
ShowIconInTray 10, lblMsg(0).Caption
If HasSound() Then
PlayWarningSound Sound
Else
Beep
End If
Else
ShowIconInTray 20, lblMsg(0).Caption
End If
wsock.SendData "QUIT" + vbCrLf
wsock.Close
TimeToCheck = Val(Interval)
'If time expires or the user requires a check
If ShowAlert Or Val(cantmensajes) > 0 Then
tmrCheck.Enabled = False
If Val(cantmensajes) < 1 Then
HideMsg
Else
ShowMsg Msgs
End If
frmMain.Visible = True
result = SetWindowPos(frmMain.hWnd, -1, 0, 0, 0, 0, 3)
tmrCheck.Enabled = True
End If
ShowAlert = True
Exit Sub
errsock:
If NotifyCommErrors Then MsgBox Err.Description, vbCritical
ShowIconInTray 30, LoadResString(Language + 14)
wsock.Close
Exit Sub
End Sub
'Call e-mail program
Private Sub mnuOptionsExecutemail_Click()
Dim rc As Double
On Error Resume Next
If EmailProgram <> "" Then
Screen.MousePointer = vbHourglass
rc = Shell(EmailProgram + " " + Arguments, vbMaximizedFocus)
Screen.MousePointer = vbNormal
If rc = 0 Then
MsgBox LoadResString(Language + 15), vbExclamation
End If
End If
End Sub
'Enable / disable the timer
Private Sub mnuOptionsHabilitado_Click()
mnuOptionsHabilitado.Checked = Not mnuOptionsHabilitado.Checked
tmrCheck.Enabled = mnuOptionsHabilitado.Checked
End Sub
'When is moment to check ?
Private Sub tmrCheck_Timer()
TimeToCheck = TimeToCheck - 1
If TimeToCheck = 0 Then
ShowAlert = False
mnuOptionsCheckNow_Click
End If
End Sub
'Captura de los mensajes del mouse
Private Sub Trayicon_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Msg As Long
Msg = (x And &HFF) * &H100
Select Case Msg
Case 0 'mouse moves
Case &HF00 'left mouse button down
Case &H1E00 'left mouse button up
Case &H3C00 'right mouse button down
PopupMenu mnuOptions 'show the popoup menu
Case &H2D00 'left mouse button double click
mnuOptionsCheckNow_Click
Case &H4B00 'right mouse button up
Case &H5A00 'right mouse button double click
End Select
End Sub
Private Sub wsock_DataArrival(ByVal bytesTotal As Long)
Dim iPos As Integer
'Store the data in a variable
wsock.GetData Response
Reply = Response
If InStr(1, Response, vbCrLf & "." & vbCrLf) Then
Response = "."
End If
If NotCommand Then
iPos = InStr(1, UCase(Reply), "FROM:")
If iPos Then
sFrom = Mid(Reply, iPos + 6)
sFrom = Left(sFrom, InStr(1, sFrom, vbCrLf) - 1)
If Left(sFrom, 1) = vbLf Then
sFrom = ""
End If
End If
iPos = InStr(1, UCase(Reply), "SUBJECT:")
If iPos Then
sSubject = Mid(Reply, iPos + 9)
sSubject = Left(sSubject, InStr(1, sSubject, vbCrLf) - 1)
If Left(sSubject, 1) = vbLf Then
sSubject = ""
End If
End If
End If
End Sub
'
'Hides the messages headers
'
Private Sub HideMsg()
lstMsgHead.Visible = False
With cmdAceptar
.Top = lstMsgHead.Top
.Left = cmdOpenEmail.Left
End With
cmdOpenEmail.Visible = False
lblTitle(0).Visible = False
lblTitle(1).Visible = False
Me.Height = 1860
End Sub
'
'Shows messages headers (if aplicable), buttons, etc
'
Sub ShowMsg(Msg() As String)
Dim i As Integer
If showmsgHeaders = True Then
lstMsgHead.Visible = True
Me.Height = 3330
Else
Me.Height = 1860
End If
With cmdAceptar
If Me.Height > 3000 Then .Top = 2280 Else .Top = lstMsgHead.Top
.Left = 2460
End With
With cmdOpenEmail
If Me.Height > 3000 Then .Top = 2280 Else .Top = lstMsgHead.Top
.Visible = True
End With
If showmsgHeaders Then
lstMsgHead.Clear
lblTitle(0).Visible = True
lblTitle(1).Visible = True
For i = 1 To UBound(Msg)
lstMsgHead.AddItem Msg(i)
Next
SetHScroll Me, lstMsgHead, lstMsgHead.List(0)
End If
End Sub
'
'Returns an array with lines containing sender and subject
'
Private Function ParseMail(nMsg As Integer) As String()
Dim pMsg() As String
Dim i As Integer, j As Integer
Dim Respuesta As String
Dim npos As Integer
ReDim pMsg(nMsg)
NotCommand = True
For i = 1 To nMsg
Debug.Print "TOP " & i
wsock.SendData "TOP " & i & " 0" + vbCrLf
If Not WaitFor(".", Respuesta) Then
Err.Raise 999998, , LoadResString(Language + 82)
End If
pMsg(i) = Trim(sFrom)
If pMsg(i) <> "" Then
pMsg(i) = Left(pMsg(i), 40) + IIf(Len(pMsg(i)) > 40, "...", "")
Else
pMsg(i) = "(Desconocido)"
End If
If Trim(sSubject) <> "" Then
pMsg(i) = pMsg(i) + Chr(9) + Trim(sSubject)
Else
pMsg(i) = pMsg(i) + Chr(9) + "(Sin tema)"
End If
Debug.Print pMsg(i)
Next
NotCommand = False
ParseMail = pMsg
End Function
'
'Error en el socket
'
Private Sub wsock_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox Err.Description, vbExclamation, Me.Caption
bErr = True
End Sub
'
'Shows an icon "spinning" in the systray
'
Private Sub SpinIconInTray()
Static nicon As Integer
If nicon = 0 Then nicon = 45
ShowIconInTray nicon, LoadResString(Language + 16)
Sleep nDelay 'wait just that
nicon = nicon + 5 'change icon - spinning
If nicon > 65 Then nicon = 45
End Sub