VFB自动校时

 #include Once "win/winsock2.bi"
Dim Shared IntTime As Double, ca As Double
'--------------------------------------------------------------------------------
Sub Form1_WM_Create(hWndForm As hWnd, UserData As Integer)  '完成创建窗口及所有的控件后，此时窗口还未显示。注：自定义消息里 WM_Create 此时还未创建控件和初始赋值。
   FORM1_TIMER1_WM_TIMER 0, 0
   Threaddetach ThreadCreate(@加载, 0) '多线程处理，避免卡顿
End Sub
'--------------------------------------------------------------------------
Sub 加载(aa As Long) '
   If FF_GetRegistryString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "勇芳_自动校时", "") = App.Path & App.EXEName & " 1" Then
      Check1.Value = 1
   End If
   IntTime = GetInternetTime
   If IntTime > 0 Then
      'FF_Control_Enable HWND_FORM1_COMMAND1  '函数和控件都可以，一样
      Me.Command1.Enabled = True
      IntTime = DateAdd("h", 8, IntTime)
      'Print Format(IntTime,  "yyyy-mm-dd hh:mm:ss ")
      ca = IntTime - Now
   End If
End Sub
'--------------------------------------------------------------------------
Function GetInternetTime() As Double  '获取网络时间,失败=0
   Dim www(2) As String = {"https://www.baidu.com/", "https://www.qq.com/", "http://www.jd.com/"}
   Dim i As Long, bb As String, ss() As String
   For i = 0 To 2
      bb = GetSocket(www(i))
      If Len(bb) > 0 Then
         bb = UCase(bb)
         vbSplit bb, " ", ss()
         'Print UBound(ss),bb
         If UBound(ss) = 4 Then
            If ss(4) = "GMT" Then
               'Print ss(1)
               Select Case ss(1)
                  Case "JAN"
                     ss(1) = "1"
                  Case "FEB"
                     ss(1) = "2"
                  Case "MAR"
                     ss(1) = "3"
                  Case "APR"
                     ss(1) = "4"
                  Case "MAY"
                     ss(1) = "5"
                  Case "JUN"
                     ss(1) = "6"
                  Case "JUL"
                     ss(1) = "7"
                  Case "AUG"
                     ss(1) = "8"
                  Case "SEP"
                     ss(1) = "9"
                  Case "OCT"
                     ss(1) = "10"
                  Case "NOV"
                     ss(1) = "11"
                  Case "DEC"
                     ss(1) = "12"
               End Select
               'Print ValInt(ss(2)),ValInt(ss(1)),ValInt(ss(0))
               Function = DateSerial(ValInt(ss(2)), ValInt(ss(1)), ValInt(ss(0))) + TimeValue(ss(3))
               Exit For
            End If
         End If
      End If
   Next
End Function
'--------------------------------------------------------------------------
Function GetSocket(www As String) As String  '联网,获取时间
   Dim As String hostname, path, sendBuffer
   Dim duiko As Integer
   Dim sa As sockaddr_in
   Dim bytes As Integer
   Dim ip As UInteger
   Dim s As SOCKET
   'Print  "初始化WinSock "
   Dim wsaData As WSAData
   If WSAStartup(MAKEWORD(1, 1), @wsaData) Then Return ""
   'Print  "检查网址 "
   URL_FenLiYuMinLuJing www, hostname, path, duiko
   If (Len(hostname) = 0) Then
      WSACleanup
      Return ""
   End If
   ip = resolveHost(hostname)
   If (ip = 0) Then
      WSACleanup
      Return ""
   End If
   s = opensocket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
   If (s = 0) Then
      WSACleanup
      Return ""
   End If
   'Print  "duiko= " & duiko
   duiko = 80
   sa.sin_port = htons(duiko)
   sa.sin_family = AF_INET
   sa.sin_addr.S_addr = ip
   'Print ip
   If (connect(s, Cast(PSOCKADDR, @sa), SizeOf(sa)) = SOCKET_ERROR) Then
      closesocket(s)
      WSACleanup
      Return ""
   End If
   sendBuffer = "GET /" + path + " HTTP/1.0" + Chr(13, 10) + _
      "Host: " + hostname + Chr(13, 10) + _
      "Connection: close" + Chr(13, 10) + _
      "User-Agent: GetHTTP 0.0" + Chr(13, 10) + _
      Chr(13, 10)
   'Print sendBuffer
   If (send(s, sendBuffer, Len(sendBuffer), 0) = SOCKET_ERROR) Then
      closesocket(s)
      WSACleanup
      Return ""
   End If
   Dim by(999) As Byte
   'Do
   'bytes = recv( s, @by(0), 4096, 0 )
   'If( bytes <= 0 ) Then
   'Exit Do
   'End If
   'sendBuffer=String(bytes,0)
   'memcpy SAdd(sendBuffer),@by(0),bytes
   'Print sendBuffer
   '
   'Loop
   bytes = recv(s, @by(0), 1000, 0)
   shutdown(s, 2) '关闭socket
   closesocket(s) '关闭socket
   WSACleanup '释放
   'Print  "释放 ",bytes
   If bytes > 0 Then
      Dim ff As Long
      sendBuffer = String(bytes, 0)
      memcpy SAdd(sendBuffer), @by(0), bytes
      ff = InStr(sendBuffer, "Date:")
      If ff > 0 Then
         Print www
         sendBuffer = Mid(sendBuffer, ff + 6)
         ff = InStr(sendBuffer, vbCrLf)
         If ff > 0 Then sendBuffer = Left(sendBuffer, ff - 1)
         ff = InStr(sendBuffer, ",")
         If ff > 0 Then
            sendBuffer = Trim(Mid(sendBuffer, ff + 1))
            Return sendBuffer
         End If
      End If
   End If
End Function
'--------------------------------------------------------------------------------
Sub Form1_Command1_BN_Clicked(hWndForm As hWnd, hWndControl As hWnd)  '单击
   SetDate Format(Now + ca, "mm/dd/yyyy")
   SetTime Format(Now + ca, "hh:mm:ss")
   Threaddetach ThreadCreate(@加载, 0)
   Command1.Enabled = False
   ca = 0
End Sub
'--------------------------------------------------------------------------------
Sub Form1_Timer1_WM_Timer(hWndForm As hWnd, wTimerID As Long)  '定时器
   If IntTime = 0 Then
      Label1.Caption = "标准的网络时间：获取中"
   Else
      Label1.Caption = "标准的网络时间：" & Format(Now + ca, "yyyy-mm-dd hh:mm:ss")
   End If
   Label2.Caption = "现在的电脑时间：" & NowString
   Picture1(0).Refresh
   Picture1(1).Refresh
End Sub
'--------------------------------------------------------------------------------
Sub Form1_Check1_BN_Clicked(hWndForm As hWnd, hWndControl As hWnd)  '单击
   If FF_Control_GetCheck(hWndControl) Then
      If FF_SetRegistryString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "勇芳_自动校时", App.Path & App.EXEName & " 1") = 0 Then
         Check1.Value = False
         MessageBox(hWndForm, "增加开机启动失败" & Chr(13, 10) & "如果杀毒软件拦截，请允许通过" & Chr(13, 10) & _
            "如果是WIN7或者以上系统，请用" & Chr(13, 10) & _
            "管理员方式打开本软件后，再设置。" & Chr(13, 10) & "正常使用软件时不可以用管理员方式打开", "勇芳_自动校时", _
            MB_OK or MB_ICONERROR or MB_DEFBUTTON1 or MB_APPLMODAL)
      End If
   Else
      FF_DeleteRegistryKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "勇芳_自动校时")
      If FF_GetRegistryString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "勇芳_自动校时", "") = App.Path & App.EXEName & " 1" Then
         Check1.Value = True
         MessageBox(hWndForm, "清除开机启动失败" & Chr(13, 10) & "如果杀毒软件拦截，请允许通过" & Chr(13, 10) & _
            "如果是WIN7或者以上系统，请用" & Chr(13, 10) & _
            "管理员方式打开本软件后，再设置。" & Chr(13, 10) & "正常使用软件时不可以用管理员方式打开", "勇芳_自动校时", _
            MB_OK or MB_ICONERROR or MB_DEFBUTTON1 or MB_APPLMODAL)
      End If
   End If
End Sub
#define pi 3.1415926
'--------------------------------------------------------------------------------
Function Form1_Picture1_WM_Paint(ControlIndex As Long, hWndForm As hWnd, hWndControl As hWnd) As LResult  '重绘，系统通知控件需要重新绘画。
   Dim As Long w, h, x, y, a, ss, mm, hh, x1, y1, x2, y2, rr, i
   Dim aa As String, Nn As Double
   Dim gg As yGDI = yGDI(hWndControl, GetSysColor(COLOR_BTNFACE), True)
   gg.GpPen 2, & HFF000000
   gg.GpBrush 0
   gg.GpDrawEllipse 2, 2, 110, 110
   x = 57
   y = 57 '圆心
   '画格子
   For i = 0 To 11
      rr = 55
      y1 = y + rr * Sin((i - 3) * (30 * pi / 180))
      x1 = x + rr * Cos((i - 3) * (30 * pi / 180))
      rr = 50
      y2 = y + rr * Sin((i - 3) * (30 * pi / 180))
      x2 = x + rr * Cos((i - 3) * (30 * pi / 180))
      gg.gpDrawLine x1, y1, x2, y2
   Next
   '画格子
   gg.GpPen 1, & HFF000000
   For i = 0 To 59
      rr = 55
      y1 = y + rr * Sin(i * 6 * (pi / 180))
      x1 = x + rr * Cos(i * 6 * (pi / 180))
      rr = 52
      y2 = y + rr * Sin(i * 6 * (pi / 180))
      x2 = x + rr * Cos(i * 6 * (pi / 180))
      gg.gpDrawLine x1, y1, x2, y2
   Next
   If ControlIndex = 0 Then nn = Now Else nn = Now + ca
   ss = Second(nn)
   mm = Minute(nn)
   hh = Hour(nn)
   '画时针
   rr = 40
   y2 = y + rr * Sin((hh * 30 + mm / 2 - 90) * (pi / 180))
   x2 = x + rr * Cos((hh * 30 + mm / 2 - 90) * (pi / 180))
   gg.gpPen 3, & HFFFF3FC0
   gg.gpDrawLine x, y, x2, y2
   '画分针
   rr = 50
   y2 = y + rr * Sin((mm * 6 - 90) * (pi / 180))
   x2 = x + rr * Cos((mm * 6 - 90) * (pi / 180))
   gg.gpPen 1, & HFF1FE080
   gg.gpDrawLine x, y, x2, y2
   
   '画秒针
   rr = 50
   y2 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x2 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   rr = 5
   ss - = 15
   If ss < 0 Then ss + = 60
   y1 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x1 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   gg.gpPen 1, GDIP_ARGB(255, 0, 0, & HFF)
   gg.gpDrawLine x1, y1, x2, y2
   rr = 5
   y2 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x2 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   rr = 15
   ss - = 15
   If ss < 0 Then ss + = 60
   y1 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x1 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   gg.gpDrawLine x1, y1, x2, y2
   rr = 15
   y2 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x2 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   rr = 5
   ss - = 15
   If ss < 0 Then ss + = 60
   y1 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x1 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   gg.gpDrawLine x1, y1, x2, y2
   rr = 5
   y2 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x2 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   rr = 50
   ss - = 15
   If ss < 0 Then ss + = 60
   y1 = y + rr * Sin((ss * 6 - 90) * (pi / 180))
   x1 = x + rr * Cos((ss * 6 - 90) * (pi / 180))
   gg.gpDrawLine x1, y1, x2, y2
   Function = True
End Function