listner.frm

Control your PC with Mobile Phone-it controls your pc using mobile phone from anywhere in the world.

'
'Parameters :
'
'Purpose    : Pop-up menu actions wre handled here
'
'Comments   :
'
'Returns    :
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'14-Jun-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
    Select Case Index
        Case 0  'About
            MsgBox "All rights reserved." + vbCrLf + "E-Mail: [e-mail]", vbInformation + vbOKOnly
        Case 2  'End
            Unload Me
    End Select
    Exit Sub
ErrTrap:
    txtLog = txtLog & "Error In ParseMail(): "
    txtLog = txtLog & Err.Description & vbCrLf
End Sub

Private Sub pichook_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo ErrTrap
'
'Parameters :
'
'Purpose    : This function is called when Double click or right
'             mouse button clicked in Notification Icon (System tray)
'
'Comments   :
'
'Returns    :
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'14-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
    Msg = X / Screen.TwipsPerPixelX
    If Msg = WM_LBUTTONDBLCLK Then  'If the user dubbel-clicked on the icon
        mnuPop_Click 0
    ElseIf Msg = WM_RBUTTONDOWN Then  'Right click
        Me.PopupMenu mnuPopUp
    End If
    Exit Sub
ErrTrap:
    txtLog = txtLog & "Error In ParseMail(): "
    txtLog = txtLog & Err.Description & vbCrLf
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrTrap
'
'Parameters
'
'Purpose    : Remove notification Icon From the systray
'
'Comments   :
'
'Returns    :
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'12-Jun-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
    TrayI.cbSize = Len(TrayI)
    TrayI.hWnd = pichook.hWnd
    TrayI.uId = 1&
    'Delete the icon
    Shell_NotifyIcon NIM_DELETE, TrayI
    End
    Exit Sub
ErrTrap:
    txtLog = txtLog & "Error In ParseMail(): "
    txtLog = txtLog & Err.Description & vbCrLf
End Sub
Private Sub Timer1_Timer()
'
'Parameters :
'
'Purpose    : To Animate Notification icon
'
'Comments   :
'
'Returns    :
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'14-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
    Static mPic As Integer
    Me.Icon = imgIcon(mPic).Picture
    TrayI.hIcon = imgIcon(mPic).Picture
    mPic = mPic + 1
    If mPic = 3 Then mPic = 0
    Shell_NotifyIcon NIM_MODIFY, TrayI
End Sub

Private Function ParseMail() As String
On Error GoTo ErrTrap
'
'Parameters
'
'Purpose      This procedure will check and let us know what action to be
'             taken aginst the command sent from mobile
'
'Comments
'
'Returns     String - Command parsed from the mail
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'29-May-04   [100]   Rasheed Created
'15-Jun-04   [101]   Rasheed Added parameter values parsing facility
'-----------+-------+-------+---------------------------------------------
'
'Set up our variables
Dim oApp        As Outlook.Application  'Create an object for outlook application
Dim oNpc        As NameSpace            'Name space to drildown message folder
Dim oMails      As MailItem             'To find our mail
Dim sCommand    As String
Dim iMsgCount   As Integer
Dim sMsgHead    As String
    'Lets apply values to our variables
    Set oApp = CreateObject("Outlook.Application")
    Set oNpc = oApp.GetNamespace("MAPI")
    iMsgCount = 0
    'Lets iterate through an easy For Each loop
    For Each oMails In oNpc.GetDefaultFolder(olFolderInbox).Items
        If oMails.UnRead Then
            sParam = ""
            'Change the Subject comparition string based on your service provider message
            If UCase(oMails.Subject) = UCase(Trim(txtSubject.Text)) Then
                sCommand = Mid(oMails.Body, 1, InStr(1, oMails.Body, Chr(13)) - 1)
                If InStr(1, sCommand, "~") <> 0 Then
                    ParseMail = Mid(sCommand, 1, InStr(1, sCommand, "~") - 1)
                    sParam = Mid(sCommand, InStr(1, sCommand, "~") + 1)
                Else
                    ParseMail = sCommand
                End If
                oMails.UnRead = False
            End If
            ' If Send Unread mail Header is checked then send info to mobile
            If chkUnReadMail.Value = 1 Then
                If UCase(oMails.Subject) <> UCase(Trim(txtSubject.Text)) Then
                    If InStr(1, sAlertedMails, Trim(oMails.EntryID)) = 0 Then
                        sAlertedMails = sAlertedMails & Trim(oMails.EntryID) & ","
                        sMsgHead = "From: " & oMails.SenderName & vbCrLf
                        sMsgHead = sMsgHead & "Sub: " & oMails.Subject & vbCrLf
                        sMsgHead = sMsgHead & "DT: " & oMails.SentOn & vbCrLf
                        sMsgHead = sMsgHead & "MSGID: " & oMails.EntryID & "~"
                        SendSMS sMsgHead
                    End If
                End If
            End If
        End If
    Next oMails
    Exit Function
ErrTrap:
    txtLog = txtLog & "Error In ParseMail(): "
    txtLog = txtLog & Err.Description & vbCrLf
End Function

Private Function SendMail(sTo As String, sSubject As String, Optional sAttachment As String = "")
On Error GoTo ErrTrap
'
'Parameters : sTo - Send mail to; sSubject - Subject of the mail; sAttachment - If any attachment path going to send with mail
'
'Purpose    : This procedure will send mail to specific address
'
'Comments   :
'
'Returns    :
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'14-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
'To send mail to specified address
Dim objApp As Outlook.Application
Dim objMailMessage As Outlook.MailItem
'
    Set objApp = New Outlook.Application
    Set objMailMessage = objApp.CreateItem(olMailItem)
    '
    objMailMessage.To = sTo
    objMailMessage.Subject = sSubject
    
    If Trim(sAttachment) <> "" Then
        objMailMessage.Attachments.Add sAttachment
    End If
    objMailMessage.Send
    '
    Exit Function
ErrTrap:
    txtLog = txtLog & "Error In ParseMail(): "
    txtLog = txtLog & Err.Description & vbCrLf
End Function

Private Sub SendSMS(sMessage As String, Optional sFrom As String = "rasheedsys")
On Error GoTo ErrTrap
'
'Parameters : sMessage - Message to be send to mobile; sFrom - Send the information from whom the message sent from
'
'Purpose    : Send SMS to the mobile device
'
'Comments   : There are many vendors availabe to do SMS serve.
'             For me www.spicesms.com given special permision to use ther server.
'             Thanks for www.spicesms.com Team
'
'             Here i am used XMLHTTP to send message to my mobile phone through internet
'Returns    :
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'17-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
Dim oXml As New MSXML2.XMLHTTP
    Call oXml.Open("POST", "http://www.spicesms.com/abc.asp?from=" & sFrom & "&msg=" & sMessage & "~") 'Cange your vendor URL appropriately
    Call oXml.setRequestHeader("Content-Type", "text/xml")
    Call oXml.Send
    txtLog = txtLog & "Status of: " & "http://www.spicesms.com/abc.asp?from=" & sFrom & "&msg=" & sMessage & "~" & vbCrLf
    txtLog = txtLog & oXml.responseText & vbCrLf
    Exit Sub
ErrTrap:
    txtLog = txtLog & "Error In ParseMail(): "
    txtLog = txtLog & Err.Description & vbCrLf
End Sub
Private Function ReadMail(sMsgId As String)
On Error GoTo ErrTrap
'Parameters
'
'Purpose      This Procedure will read message and send it as SMS
'
'Comments
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'08-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
'Set up our variables
Dim oApp        As Outlook.Application  'Create an object for outlook application
Dim oNpc        As NameSpace            'Name space to drildown message folder
Dim oMails      As MailItem             'To find our mail
Dim sMsg        As String
Dim lPos        As Long
'
    'Lets apply values to our variables
    Set oApp = CreateObject("Outlook.Application")
    Set oNpc = oApp.GetNamespace("MAPI")
    '
    'Lets iterate through an easy For Each loop
    For Each oMails In oNpc.GetDefaultFolder(olFolderInbox).Items
        If oMails.UnRead Then
            If Trim(UCase(Trim(oMails.EntryID))) = Trim(UCase(Trim(sMsgId))) Then
                'Read mail and send it as SMS
                sMsg = "Sub: " & oMails.Subject & vbCrLf
                If oMails.Attachments.Count <> 0 Then
                    sMsg = sMsg & "Att: Haves Attach"
                End If
                sMsg = sMsg & "Body: " & oMails.Body & "  "
                lPos = InStr(1, sMsg, "Original Message")
                If lPos > 0 Then
                    sMsg = Mid(sMsg, 1, lPos)
                End If
                SendSMS sMsg
            End If
        End If
    Next oMails
    Exit Function
ErrTrap:
    txtLog = txtLog & Err.Description & vbCrLf
End Function
Private Function CheckMail() As Integer
On Error GoTo ErrTrap
'
'Parameters
'
'Purpose      This Procedure Count number of unread mails in inbox
'
'Comments
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'08-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
'Set up our variables
Dim oApp        As Outlook.Application  'Create an object for outlook application
Dim oNpc        As NameSpace            'Name space to drildown message folder
Dim oMails      As MailItem             'To find our mail
Dim iMsgCount   As Integer
'
    'Lets apply values to our variables
    Set oApp = CreateObject("Outlook.Application")
    Set oNpc = oApp.GetNamespace("MAPI")
    '
    'Lets iterate through an easy For Each loop
    iMsgCount = 0
    For Each oMails In oNpc.GetDefaultFolder(olFolderInbox).Items
        If oMails.UnRead Then
            iMsgCount = iMsgCount + 1
        End If
    Next
    CheckMail = iMsgCount
    Exit Function
ErrTrap:
    txtLog = txtLog & Err.Description & vbCrLf

End Function

Private Function ReadMailHeader()
On Error GoTo ErrTrap
'
'Parameters
'
'Purpose      This Procedure Reads Mail Header info and send it as SMS
'
'Comments
'
'Change History
'Date        Edit    Author  Comment
'-----------+-------+-------+---------------------------------------------
'08-Jul-04   [100]   Rasheed Created
'-----------+-------+-------+---------------------------------------------
'
'Set up our variables
Dim oApp        As Outlook.Application  'Create an object for outlook application
Dim oNpc        As NameSpace            'Name space to drildown message folder
Dim oMails      As MailItem             'To find our mail
Dim sMsgHead    As String
'
    'Lets apply values to our variables
    Set oApp = CreateObject("Outlook.Application")
    Set oNpc = oApp.GetNamespace("MAPI")
    '
    'Lets iterate through an easy For Each loop
    sMsgHead = ""
    For Each oMails In oNpc.GetDefaultFolder(olFolderInbox).Items
        If oMails.UnRead Then
            sMsgHead = "From: " & oMails.SenderName & vbCrLf
            sMsgHead = sMsgHead & "Sub: " & oMails.Subject & vbCrLf
            sMsgHead = sMsgHead & "DT: " & oMails.SentOn & vbCrLf
            sMsgHead = sMsgHead & "MSGID: " & oMails.EntryID & "  "
            SendSMS sMsgHead
        End If
    Next
    Exit Function
ErrTrap:
    txtLog = txtLog & Err.Description & vbCrLf
End Function

Private Sub txtInterval_LostFocus()
    If Val(Trim(txtInterval)) > 60 Or Val(Trim(txtInterval)) < 0 Then
        MsgBox "Check Interval should be between 1 to 60 seconds", vbInformation
        txtInterval.SetFocus
    End If
End Sub