frmmain.frm

PIC16F877A RTC1307 LCD 16x2 keypad 4x4 and a windows application connect with PIC on RS232

VERSION 5.00
Object = "{6BF52A50-394A-11D3-B153-00C04F79FAA6}#1.0#0"; "wmp.dll"
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "mscomm32.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Form1"
   ClientHeight    =   810
   ClientLeft      =   105
   ClientTop       =   105
   ClientWidth     =   4110
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   810
   ScaleWidth      =   4110
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.Timer Timer2 
      Enabled         =   0   'False
      Interval        =   10000
      Left            =   2280
      Top             =   120
   End
   Begin VB.Timer Timer1 
      Interval        =   10000
      Left            =   1800
      Top             =   120
   End
   Begin MSWinsockLib.Winsock Winsock 
      Left            =   1260
      Top             =   105
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin MSComDlg.CommonDialog CommonDialog 
      Left            =   735
      Top             =   105
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSCommLib.MSComm MSComm 
      Left            =   105
      Top             =   105
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   0   'False
      NullDiscard     =   -1  'True
      BaudRate        =   2400
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   330
      Left            =   105
      TabIndex        =   1
      Top             =   840
      Width           =   3900
   End
   Begin WMPLibCtl.WindowsMediaPlayer WindowsMediaPlayer 
      Height          =   675
      Left            =   105
      TabIndex        =   0
      Top             =   105
      Width           =   3960
      URL             =   ""
      rate            =   1
      balance         =   0
      currentPosition =   0
      defaultFrame    =   ""
      playCount       =   1
      autoStart       =   -1  'True
      currentMarker   =   0
      invokeURLs      =   -1  'True
      baseURL         =   ""
      volume          =   50
      mute            =   0   'False
      uiMode          =   "full"
      stretchToFit    =   0   'False
      windowlessVideo =   0   'False
      enabled         =   -1  'True
      enableContextMenu=   -1  'True
      fullScreen      =   0   'False
      SAMIStyle       =   ""
      SAMILang        =   ""
      SAMIFilename    =   ""
      captioningID    =   ""
      enableErrorDialogs=   0   'False
      _cx             =   6985
      _cy             =   1191
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuSelect 
         Caption         =   "&Select song"
      End
      Begin VB.Menu mnuSep 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "&Exit"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'User-defined variable to pass to the Shell_NotiyIcon function
Private 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

Dim sNTP As String      'the 32bit time stamp returned by the server
Dim TimeDelay As Single 'the time between the acknowledgement of
Dim ST As SYSTEMTIME
Dim NISTServer As String
Dim num_server As Integer

Private Declare Function SetSystemTime Lib "kernel32" _
    (lpSystemTime As SYSTEMTIME) As Long

Private Sub AddIcon(ByVal ToolTip As String)
    On Error GoTo ErrorHandler
    'Add icon to system tray
    With nid
        .cbSize = Len(nid)
        .hWnd = Me.hWnd
        .uID = vbNull
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uCallbackMessage = WM_MOUSEMOVE
        .hIcon = Me.Icon
        .szTip = ToolTip & vbNullChar
    End With
    Call Shell_NotifyIcon(NIM_ADD, nid)
    Exit Sub
ErrorHandler:   'Display error message
    Screen.MousePointer = vbDefault
    MsgBox Err.Description, vbInformation, App.ProductName & " - " & Me.Caption
End Sub

Private Sub Form_Load()
    Dim song As String
    Dim exists As Boolean
    Dim path As String
    Dim filename As String
    Dim filenum As String
    
    MSComm.RThreshold = 1
    MSComm.PortOpen = True
    mnuFile.Visible = False
    num_server = 0
    Label1.Caption = "Ready to update date and time"
    Call change_server
    Call AddIcon("Alarm clock ...")
    'Me.Hide
    filename = App.path & "\test.txt"
    exists = FileExists(filename)
    If exists = False Then
dialog: MsgBox "Please select a song, click OK to select"
        song = OpenDialog()
        If song = "" Then
            GoTo dialog
        Else
            filenum = FreeFile
            Open filename For Output As filenum
            Write #filenum, song
            Close filenum
        End If
    End If
    WindowsMediaPlayer.settings.volume = 100
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim msg As Long
    On Error GoTo ErrorHandler
    'Respond to user interaction
    msg = X / Screen.TwipsPerPixelX
    Select Case msg
        Case WM_LBUTTONDBLCLK
            'nothing
        Case WM_LBUTTONDOWN
            'nothing
        Case WM_LBUTTONUP
            If Me.WindowState = vbMinimized Then
                Me.WindowState = vbNormal
                Me.Show
            Else
                Me.WindowState = vbMinimized
                Me.Hide
            End If
        Case WM_RBUTTONDBLCLK
            'nothing
        Case WM_RBUTTONDOWN
            'nothing
        Case WM_RBUTTONUP
            Call PopupMenu(mnuFile, vbPopupMenuRightAlign)
    End Select
    Exit Sub
ErrorHandler:           'Display error message
    Screen.MousePointer = vbDefault
    MsgBox Err.Description, vbInformation, App.ProductName & " - " & Me.Caption
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'Remove icon from system tray
    Call Shell_NotifyIcon(NIM_DELETE, nid)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    WindowsMediaPlayer.Controls.stop
End Sub

Private Sub mnuExit_Click()
    Winsock.Close
    Unload Me
    End
End Sub

Private Sub mnuSelect_Click()
    Dim song As String
    Dim path As String
    Dim filename As String
    Dim filenum As String
    song = OpenDialog()
    If song <> "" Then
        filename = App.path & "\test.txt"
        filenum = FreeFile
        Open filename For Output As filenum
        Write #filenum, song
        Close filenum
    End If
End Sub

Private Function FileExists(sFullPath As String) As Boolean
    Dim oFile As New Scripting.FileSystemObject
    FileExists = oFile.FileExists(sFullPath)
End Function

Private Function OpenDialog() As String
    Dim Filter As String
    Dim songname As String
    Filter = "*.mp3|*.mp3;|"
    Filter = Filter + "*.wma|*.wma;|"
    Filter = Filter + "*.wmv|*.wmv;|"
    Filter = Filter + "All Formats(*.*)|*.mp3,*.wma,*.wmv|"
    CommonDialog.Filter = Filter 'This is how you make the filter show in the filter section
    CommonDialog.FilterIndex = 1 'Makes the *.wma extention come up first as default
    CommonDialog.ShowOpen
    songname = CommonDialog.filename
    OpenDialog = songname
End Function

Private Sub MSComm_OnComm()
    Dim stroncomm As String
    stroncomm = MSComm.Input
    Select Case stroncomm
        Case "Alarm":
            Call Playmusic
        Case "Login":
            Timer1.Enabled = False
            Timer2.Enabled = False
            Winsock.Close
            Label1.Caption = "Stop updating"
        Case "Logout":
            Timer1.Enabled = True
            Label1.Caption = "Ready to update date and time"
    End Select
End Sub

Private Sub Playmusic()
    Dim path As String
    Dim filename As String
    Dim filenum As String
    Dim song As String
    filename = App.path & "\test.txt"
    filenum = FreeFile
    Open filename For Input As filenum
    Do Until EOF(filenum)
        Line Input #filenum, song
    Loop
    Close filenum
    Dim stringlen As Integer
    stringlen = Len(song)
    song = Mid(song, 2, stringlen - 2)
    WindowsMediaPlayer.URL = song
    WindowsMediaPlayer.Controls.play
End Sub

Private Sub Updatetime()
    Dim temp As SYSTEMTIME
    Label1.Caption = "Updating from server " + Str(num_server) + ": " + NISTServer
    Timer2.Enabled = True
    sNTP = Empty
    'connect
    With Winsock
        If .State <> sckClosed Then .Close
        .RemoteHost = NISTServer
        .RemotePort = 37  'port 37 is the timserver port
        .Connect
    End With
End Sub

Private Function Int_to_bcd(m_input As Integer) As Byte
    Dim temp As Byte
    temp = m_input \ 10
    temp = temp * 16
    temp = temp Or (m_input Mod 10)
    Int_to_bcd = temp
End Function

Private Function Bcd_hight(m_input As Integer) As Byte
    Dim temp As Byte
    temp = m_input \ 10
    Bcd_hight = temp
End Function

Private Function Bcd_low(m_input As Integer) As Byte
    Dim temp As Byte
    temp = m_input Mod 10
    Bcd_low = temp
End Function

Private Sub Timer1_Timer()
    Timer1.Enabled = False
    Call Updatetime
End Sub

Private Sub Timer2_Timer()
    Winsock.Close
    Timer2.Enabled = False
    If (num_server = 5) Then
        num_server = 0
        Call change_server
        Call Updatetime
    End If
    If (num_server < 5) Then
        Call change_server
        Call Updatetime
    End If
End Sub

Private Sub Winsock_Close()
    On Error Resume Next
    Winsock.Close
    Call SyncSystemClock(sNTP)
End Sub

Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
    Dim sData As String
    Winsock.GetData sData, vbString
    sNTP = sNTP & sData
End Sub

Private Sub Winsock_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)
    Timer2.Enabled = False
    If (num_server = 5) Then
        num_server = 0
        Call change_server
        Call Updatetime
    End If
    If (num_server < 5) Then
        Call change_server
        Call Updatetime
    End If
  'if an error occurred, assure the socket is closed
   If Number > 0 Then
      If Winsock.State <> sckClosed Then
         Winsock.Close
      End If
   End If
End Sub

Private Sub change_server()
    num_server = num_server + 1
    Select Case num_server
        Case 1: NISTServer = "time.nist.gov"
        Case 2: NISTServer = "time-a.timefreq.bldrdoc.gov"
        Case 3: NISTServer = "time-b.timefreq.bldrdoc.gov"
        Case 4: NISTServer = "time-c.timefreq.bldrdoc.gov"
        Case 5: NISTServer = "time-a.nist.gov"
        Case 6: NISTServer = "nist1.aol-va.truetime.com"
    End Select
End Sub

Private Sub SyncSystemClock(ByVal sTime As String)
    Dim start_send As Integer
    Dim NTPTime As Double
    Dim UTCDATE As Date
    Dim dwSecondsSince1990 As Long
    
    sTime = Trim(sTime)
    If Len(sTime) = 4 Then
        'Computing time just read from server
        NTPTime = Asc(Left$(sTime, 1)) * (256 ^ 3) + _
        Asc(Mid$(sTime, 2, 1)) * (256 ^ 2) + _
        Asc(Mid$(sTime, 3, 1)) * (256 ^ 1) + _
        Asc(Right$(sTime, 1))
        dwSecondsSince1990 = NTPTime - 2840140800#
        UTCDATE = DateAdd("s", CDbl(dwSecondsSince1990), #1/1/1990#)
        
        'update time that read from server to St
        With ST
            .wDay = Day(UTCDATE)
            .wMonth = Month(UTCDATE)
            .wYear = Year(UTCDATE)
            .wHour = Hour(UTCDATE)
            .wMinute = Minute(UTCDATE)
            .wSecond = Second(UTCDATE)
        End With
        If SetSystemTime(ST) Then
            UTCDATE = Now
            With ST
                .wDay = Day(UTCDATE)
                .wMonth = Month(UTCDATE)
                .wYear = Year(UTCDATE) - 2000
                .wHour = Hour(UTCDATE)
                .wMinute = Minute(UTCDATE)
                .wSecond = Second(UTCDATE)
            End With
            start_send = 70
            MSComm.Output = Chr(Int_to_bcd(start_send))
            MSComm.Output = Chr(Int_to_bcd(ST.wDay))
            MSComm.Output = Chr(Int_to_bcd(ST.wMonth))
            MSComm.Output = Chr(Bcd_hight(ST.wYear))
            MSComm.Output = Chr(Bcd_low(ST.wYear))
            MSComm.Output = Chr(Int_to_bcd(ST.wHour))
            MSComm.Output = Chr(Int_to_bcd(ST.wMinute))
            MSComm.Output = Chr(Int_to_bcd(ST.wSecond))
            Label1.Caption = "Updated from " + NISTServer
            Timer1.Enabled = True
            Timer2.Enabled = False
        End If
    End If
End Sub