'*
'* 翔泳社 Windows Developer Magazine
'* 
'* 連載『ざっくりわかる、インターネットプログラミング』 サンプルソース
'* Copyright (C)2005 SHOEISYA & 山崎はるか
'* 
'* 翔泳社 http://www.shoeisha.com/mag/windev/
'*
'* 山崎はるか http://www.nda.co.jp/
'*

Imports System.Net 'IPHostEntry , IPEndPoint
Imports System.Net.Sockets 'UdpClient , SocketException

Public Class Form1
    Inherits System.Windows.Forms.Form

    Dim Bdata(47) As Byte   '送受信用バイナリ配列 (外部変数とする)

#Region " Windows フォーム デザイナで生成されたコード "

    Public Sub New()
        MyBase.New()

        ' この呼び出しは Windows フォーム デザイナで必要です。
        InitializeComponent()

        ' InitializeComponent() 呼び出しの後に初期化を追加します。

    End Sub

    ' Form は、コンポーネント一覧に後処理を実行するために dispose をオーバーライドします。
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    ' Windows フォーム デザイナで必要です。
    Private components As System.ComponentModel.IContainer

    ' メモ : 以下のプロシージャは、Windows フォーム デザイナで必要です。
    'Windows フォーム デザイナを使って変更してください。  
    ' コード エディタを使って変更しないでください。
    Friend WithEvents Button1 As System.Windows.Forms.Button
    Friend WithEvents TextBox1 As System.Windows.Forms.TextBox
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(Form1))
        Me.Button1 = New System.Windows.Forms.Button
        Me.TextBox1 = New System.Windows.Forms.TextBox
        Me.SuspendLayout()
        '
        'Button1
        '
        Me.Button1.Location = New System.Drawing.Point(64, 80)
        Me.Button1.Name = "Button1"
        Me.Button1.Size = New System.Drawing.Size(120, 32)
        Me.Button1.TabIndex = 0
        Me.Button1.Text = "時刻調整！"
        '
        'TextBox1
        '
        Me.TextBox1.Location = New System.Drawing.Point(8, 24)
        Me.TextBox1.Name = "TextBox1"
        Me.TextBox1.Size = New System.Drawing.Size(232, 19)
        Me.TextBox1.TabIndex = 1
        Me.TextBox1.Text = "time.windows.com"
        '
        'Form1
        '
        Me.AutoScaleBaseSize = New System.Drawing.Size(5, 12)
        Me.ClientSize = New System.Drawing.Size(248, 150)
        Me.Controls.Add(Me.TextBox1)
        Me.Controls.Add(Me.Button1)
        Me.Icon = CType(resources.GetObject("$this.Icon"), System.Drawing.Icon)
        Me.Name = "Form1"
        Me.Text = "SNTPクライアント"
        Me.ResumeLayout(False)

    End Sub

#End Region

    'リスト 3  (sample3)
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

        Try

            '設定
            Dim udpc As UdpClient = New UdpClient
            Dim IPhost As IPHostEntry = Dns.Resolve(TextBox1.Text)
            Dim EPhost As IPEndPoint = New IPEndPoint(IPhost.AddressList(0), 123)

            '接続
            udpc.Connect(EPhost)

            '交信
            Bdata(0) = &H1B
            SetDecimalSec(40, DateTime.UtcNow)
            udpc.Send(Bdata, Bdata.Length)   '送信

            Bdata = udpc.Receive(EPhost)     '受信
            If Bdata.Length < 48 Then
                Throw New Exception("サーバーが応答しません")
            Else
                Dim dstr As String      '表示用文字列

                dstr = "LI " + RetLI() + ControlChars.CrLf
                dstr += "NTP ver." + RetVN() + ControlChars.CrLf
                dstr += "Mode " + RetMode() + ControlChars.CrLf
                dstr += "Stratum " + RetStratum() + ControlChars.CrLf
                dstr += "PollInterval " + RetPollInterval() + ControlChars.CrLf
                dstr += "Precision " + RetPrecision() + ControlChars.CrLf
                dstr += "RootDelay " + RetRootDelay() + ControlChars.CrLf
                dstr += "RootDispersion " + RetRootDispersion() + ControlChars.CrLf
                dstr += "ReferenceIdentifier " + RetReferenceIdentifier() + ControlChars.CrLf
                dstr += ControlChars.CrLf

                '日付・時刻部分
                dstr += RetCalDateTZone(GetDecimalSec(16)).ToString + " 参照タイムスタンプ ReferenceTimestamp" + ControlChars.CrLf
                dstr += RetCalDateTZone(GetDecimalSec(24)).ToString + "  発信タイムスタンプ OriginateTimestamp" + ControlChars.CrLf
                dstr += RetCalDateTZone(GetDecimalSec(32)).ToString + "  受信タイムスタンプ ReceiveTimestamp" + ControlChars.CrLf
                dstr += RetCalDateTZone(GetDecimalSec(40)).ToString + "  送信タイムスタンプ TransmitTimestamp" + ControlChars.CrLf

                '時刻を設定
                SetTime() '←時刻設定APIのコールルーチン（ソース末尾）
                MessageBox.Show(dstr)
            End If

            '（切断）解放 ※UDPに切断の概念はないが ポートを解放する必要はある
            udpc.Close()

        Catch ex As SocketException
            Throw New Exception(ex.Message)
        End Try


    End Sub

    'Leap indicator フィールド 
    Private Function RetLI() As String
        Dim bary As String

        bary = "00000000" + Convert.ToString(Bdata(0), 2)
        bary = bary.Substring(Len(bary) - 8)

        Select Case Convert.ToInt32(bary.Substring(0, 2), 2) '11xxxxxx bit
            Case 0
                RetLI = "0 - 無警告 No warning"
            Case 1
                RetLI = "1 - 最後は61秒からなる Last minute has 61 seconds"
            Case 2
                RetLI = "2 - 最後は59秒からなる Last minute has 59 seconds"
            Case 3
                RetLI = "3 - アラーム (clock not synchronized)"
            Case Else
                RetLI = "x - Unknown"
        End Select

    End Function

    'Version Number フィールド 
    Private Function RetVN() As String
        Dim bary As String
        Dim a As Integer

        bary = "00000000" + Convert.ToString(Bdata(0), 2)
        bary = bary.Substring(Len(bary) - 8)
        a = Convert.ToInt32(bary.Substring(2, 3), 2) 'xx111xxx bit

        RetVN = a.ToString

    End Function

    'Mode フィールド 
    Private Function RetMode() As String

        Dim bary As String

        bary = "00000000" + Convert.ToString(Bdata(0), 2)
        bary = bary.Substring(Len(bary) - 8)

        Select Case Convert.ToInt32(bary.Substring(5, 3), 2) 'xxxxx111 bit
            Case 0
                RetMode = "0 - 予約 Reserved"
            Case 1
                RetMode = "1 - 能動 Symmetric active"
            Case 2
                RetMode = "2 - 受動 Symmetric pasive"
            Case 3
                RetMode = "3 - クライアント Client"
            Case 4
                RetMode = "4 - サーバー Server"
            Case 5
                RetMode = "5 - 同報 Broadcast"
            Case 6
                RetMode = "6 - NTP制御メッセージ NTP control message(Reserved)"
            Case 7
                RetMode = "7 - プライベート Private(Reserved)"
            Case Else
                RetMode = "x - Unknown"
        End Select

    End Function

    'Stratum フィールド 
    Private Function RetStratum() As String

        Dim a As Integer

        a = CInt(Bdata(1))
        Select Case a
            Case 0
                RetStratum = "0 - 無指定 unspecified or unavailable"
            Case 1
                RetStratum = "1 - プライマリ参照(電波時計等) primary reference (e.g. radio-clock)"
            Case Else
                If a >= 2 And a <= 15 Then
                    RetStratum = a.ToString + "レベル - セカンダリ参照 secondary reference (via NTP or SNTP)"
                Else
                    RetStratum = a.ToString + "レベル - 予約 reserved"
                End If
        End Select

    End Function

    'PollInterval フィールド 
    Private Function RetPollInterval() As String
        Dim a As Integer
        Dim pt As Long

        a = CInt(Bdata(2))
        pt = 2 ^ a
        RetPollInterval = a.ToString + " → " + pt.ToString + "sec"

    End Function

    'Precision フィールド 
    Private Function RetPrecision() As String
        Dim a As Integer
        Dim pt As Long

        a = CInt(Bdata(3))
        If a >= 128 Then
            a = (256 - a) * -1
        End If

        RetPrecision = a.ToString

    End Function

    'RootDelay フィールド 
    Private Function RetRootDelay() As String

        Dim b As Long
        b = 256 * (256 * (256 * Bdata(4) + Bdata(5)) + Bdata(6)) + Bdata(7)

        RetRootDelay = (1000 * ((b) / &H10000)).ToString + " msec(ルート遅延)"

    End Function

    'RootDispersion フィールド 
    Private Function RetRootDispersion() As String

        Dim b As Long
        b = 256 * (256 * (256 * Bdata(8) + Bdata(9)) + Bdata(10)) + Bdata(11)

        RetRootDispersion = (1000 * ((b) / &H10000)).ToString + " msec(ルート拡散)"

    End Function

    'Reference Identifier フィールド
    Private Function RetReferenceIdentifier() As String
        Dim dstr As String
        Dim bary As String
        Dim verno As Integer

        bary = "00000000" + Convert.ToString(Bdata(0), 2)
        bary = bary.Substring(Len(bary) - 8)
        verno = Convert.ToInt32(bary.Substring(2, 3), 2) 'バージョン番号を取得


        Select Case CInt(Bdata(1))
            Case 0 Or 1
                If Bdata(12) <> 0 Then dstr += Chr(Bdata(12))
                If Bdata(13) <> 0 Then dstr += Chr(Bdata(13))
                If Bdata(14) <> 0 Then dstr += Chr(Bdata(14))
                If Bdata(15) <> 0 Then dstr += Chr(Bdata(15))
                dstr += "←参照クロック識別子"
            Case Else
                If verno = 3 Then 'Ver3
                    Dim adrs As String = Bdata(12).ToString + "." + _
                                            Bdata(13).ToString + "." + _
                                            Bdata(14).ToString + "." + _
                                            Bdata(15).ToString
                    Try
                        Dim Host As IPHostEntry = Dns.GetHostByAddress(adrs)
                        dstr = Host.HostName + " (" + adrs + ") ←上位取得先"
                    Catch e As Exception
                        dstr = "Unknown"
                    End Try
                Else
                    dstr = "Unknown"
                End If
        End Select

        RetReferenceIdentifier = dstr
    End Function

    'バイト配列の指定部分から 1900/1/1を基準とした相対秒数を取得
    Private Function GetDecimalSec(ByVal offset As Byte) As Decimal
        Dim sa1 As Decimal = 0  '秒の整数部
        Dim sa2 As Decimal = 0  '秒の端数部
        Dim a As Integer

        For a = 0 To 3
            sa1 = 256 * sa1 + Bdata(offset + a)
        Next
        For a = 4 To 7
            sa2 = 256 * sa2 + Bdata(offset + a)
        Next

        GetDecimalSec = Decimal.Floor(sa1 * 1000 + (sa2 * 1000) / &H100000000L)
    End Function

    'バイト配列の指定部分に 1900/1/1を基準とした相対秒数をセット
    Private Sub SetDecimalSec(ByVal offset As Byte, ByVal aday As DateTime)

        Dim sa1 As Decimal = 0  '秒の整数部
        Dim sa2 As Decimal = 0  '秒の端数部
        Dim a As Integer
        Dim n As Decimal

        Dim basetime As DateTime = New DateTime(1900, 1, 1, 0, 0, 0)
        Dim msec As Decimal = aday.Subtract(basetime).TotalMilliseconds

        sa1 = Int(msec / 1000)
        sa2 = Int(((msec Mod 1000) * &H100000000L) / 1000)

        n = sa1
        For a = 3 To 0 Step -1
            Bdata(offset + a) = Int(n Mod 256)
            n = n / 256
        Next
        n = sa2
        For a = 7 To 4 Step -1
            Bdata(offset + a) = Int(n Mod 256)
            n = n / 256
        Next

    End Sub

    'ミリセカンド(msec) を ベースの1900/1/1 に加算して、日付・時刻を得る
    ' ※本ソースでは 呼び出していないが、改良時に必要になるはずなので あえて残した
    Private Function RetCalDate(ByVal msec As Decimal) As DateTime
        Dim ts As TimeSpan = TimeSpan.FromMilliseconds(msec)
        Dim time As DateTime = New DateTime(1900, 1, 1)

        time = time.Add(ts)
        RetCalDate = time
    End Function

    'ミリセカンド(msec) を ベースの1900/1/1 に加算して、タイムゾーンで補正した日付・時刻を得る
    Private Function RetCalDateTZone(ByVal msec As Decimal) As DateTime
        Dim ts As TimeSpan = TimeSpan.FromMilliseconds(msec)
        Dim time As DateTime = New DateTime(1900, 1, 1)

        time = time.Add(ts)
        time = time.Add(TimeZone.CurrentTimeZone.GetUtcOffset(DateTime.Now))
        RetCalDateTZone = time
    End Function


    ' SetLocalTime API 宣言
    ' ※ VB6.0との違い SYSTEMTIMEを参照渡し・戻り値は Integer

    Private Declare Function SetLocalTime Lib "kernel32" _
                      Alias "SetLocalTime" (ByRef lpSystemTime As SYSTEMTIME) As Integer

    'SYSTEMTIME 構造体  （DateTimeと中身は同じ）
    Private Structure SYSTEMTIME
        Public year As Short
        Public month As Short
        Public dayOfWeek As Short
        Public day As Short
        Public hour As Short
        Public minute As Short
        Public second As Short
        Public milliseconds As Short
    End Structure

    'PCに時刻を設定する
    Private Sub SetTime()
        Dim st As SYSTEMTIME
        Dim dt As DateTime = RetCalDateTZone(GetDecimalSec(40))

        st.year = dt.Year
        st.month = dt.Month
        st.dayOfWeek = dt.DayOfWeek
        st.day = dt.Day
        st.hour = dt.Hour
        st.minute = dt.Minute
        st.second = dt.Second
        st.milliseconds = dt.Millisecond
        SetLocalTime(st)
    End Sub

End Class
