开发思路
根据系统生成高考倒计时的具体时间，附加江苏省省统考的时间生成算法，并且用户可以根据实际情况调整前后30天，具有丰富多彩的图片库和强大的自定义功能，效果图见P3
目前程序处于正式版的1.4版本，本程序由本作者开发，平台Windows，dotnet-Core8.0，兼容win7、win10、win11，即目前主流的操作系统
实现方式
使用本人开发理念时间距离计算算法和窗口嵌入功能嵌入桌面背景
感谢 wenshitao
提供的部分代码，GitHub开源项目：（P2）AnimateBackgroundWinform/gui_animate_destop/Util.cs at master · Nakasu-ksm/AnimateBackgroundWinform · GitHub
农历系统的类库稳定版需要Core版本，所以FrameWork开发者可以尝试将代码移植到Core跨平台上面（P1）
P1：YiJingFramework.Nongli
P2：快照-2024年9月16日 00点26分截图
本程序实现效果图：
P3：效果图
大部分代码MainForm的代码，开源文件会上传CSDN和GitHub百度网盘，详见文章末尾
Class Util：
vbnet
Imports System
Imports System.Collections.Generic
Imports System.Linq
Imports System.Text
Imports System.Threading.Tasks
Imports System.Windows.Forms
Imports System.Threading
Imports System.Security.Principal
Class Util
Private Shared progmanPtr As IntPtr
Private Shared sendMessageBack As IntPtr
Private Shared workWPtr As IntPtr
Public Shared Function IsAdmin() As Boolean
Dim current As WindowsIdentity = WindowsIdentity.GetCurrent()
Dim checkUser As WindowsPrincipal = New WindowsPrincipal(current)
Return checkUser.IsInRole(WindowsBuiltInRole.Administrator)
End Function
Public Sub SetAnimeBackground(ByVal videoPtr As IntPtr)
Dim windows_version As Double = Environment.OSVersion.Version.Major
progmanPtr = FindWindow("Progman", Nothing)
If progmanPtr = IntPtr.Zero Then
MessageBox.Show("当前系统可能不支持运行本程序或者卡死")
Return
Else
SendMessageTimeout(progmanPtr, &H52C, IntPtr.Zero, IntPtr.Zero, 0, &H3E8, sendMessageBack)
EnumWindows(Function(hwnd, param)
If Win32.FindWindowEx(hwnd, IntPtr.Zero, "SHELLDLL_DefView", Nothing) <> IntPtr.Zero Then
workWPtr = Win32.FindWindowEx(IntPtr.Zero, hwnd, "WorkerW", Nothing)
If windows_version < 6.2 Then
Win32.ShowWindow(workWPtr, 0)
End If
End If
Return True
End Function, 0)
If windows_version < 6.2 Then
SetParent(videoPtr, progmanPtr)
Else
SetParent(videoPtr, workWPtr)
End If
Thread.Sleep(500)
SetWindowPos(videoPtr, IntPtr.Zero, 0, 0, Win32.GetSystemMetrics(0), Win32.GetSystemMetrics(1), 0)
Thread.Sleep(100)
'VideoForm.videoForm.Show()
End If
End Sub
End ClassWin32：
vbnet
Imports System
Imports System.Collections.Generic
Imports System.Linq
Imports System.Text
Imports System.Threading.Tasks
Imports Microsoft.Win32
Imports System.Runtime.InteropServices
Public Module Win32
<DllImport("user32.dll")>
Public Function FindWindow(ByVal className As String, ByVal winName As String) As IntPtr
End Function
<DllImport("user32.dll")>
Public Function SendMessageTimeout(ByVal hwnd As IntPtr, ByVal msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr, ByVal fuFlage As UInteger, ByVal timeout As UInteger, ByVal result As IntPtr) As IntPtr
End Function
<DllImport("user32.dll")>
Public Function EnumWindows(ByVal proc As EnumWindowsProc, ByVal lParam As Integer) As Boolean
End Function
Public Delegate Function EnumWindowsProc(ByVal hwnd As IntPtr, ByVal lParam As IntPtr) As Boolean
<DllImport("user32.dll")>
Public Function FindWindowEx(ByVal hwndParent As IntPtr, ByVal hwndChildAfter As IntPtr, ByVal className As String, ByVal winName As String) As IntPtr
End Function
<DllImport("user32.dll")>
Public Function ShowWindow(ByVal hwnd As IntPtr, ByVal nCmdShow As Integer) As Boolean
End Function
<DllImport("user32.dll")>
Public Function SetParent(ByVal hwnd As IntPtr, ByVal parentHwnd As IntPtr) As IntPtr
End Function
<DllImport("user32.dll", EntryPoint:="GetSystemMetrics")>
Public Function GetSystemMetrics(ByVal which As Integer) As Integer
End Function
<DllImport("gdi32.dll", EntryPoint:="GetDeviceCaps", SetLastError:=True)>
Public Function GetDeviceCaps(ByVal hdc As IntPtr, ByVal nIndex As Integer) As Integer
End Function
<DllImport("user32.dll")>
Public Sub SetWindowPos(ByVal hwnd As IntPtr, ByVal hwndInsertAfter As IntPtr, ByVal X As Integer, ByVal Y As Integer, ByVal width As Integer, ByVal height As Integer, ByVal flags As UInteger)
End Sub
End ModuleMainForm
vbnet
Imports System.ComponentModel
Imports System.Drawing.Drawing2D
Imports System.Globalization
Imports System.Runtime.InteropServices
Imports System.Text
Imports YiJingFramework
Imports YiJingFramework.Nongli
Imports YiJingFramework.Nongli.Extensions
Imports YiJingFramework.Nongli.Lunar
Public Class MainForm
Dim s As String
Dim f1, f2 As Font
Dim t As New TextBox
Dim size As Size = Screen.PrimaryScreen.Bounds.Size
Dim bmp As New Bitmap(size.Width, size.Height)
Dim g As Graphics = Graphics.FromImage(bmp)
Dim vis As Boolean
Dim bmpindex As Integer = -1
Dim errcount As Integer
Dim mode As Integer
Function GetNongLi()
Dim dateTime = Date.Now
Dim lunar = LunarDateTime.FromGregorian(dateTime)
' Return
Return ($"{lunar.Nian:C}年 " + $"{lunar.YueInChinese()}月" + $"{lunar.RiInChinese()}")
End Function
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Try
s = IO.File.ReadAllText(Application.StartupPath & "\config")
t.Text = s
If gl(0) = 1 Then
RadioButton1.Checked = True
mode = 1
ElseIf gl(0) = 2 Then
RadioButton2.Checked = True
mode = 2
ElseIf gl(0) = 3 Then
RadioButton3.Checked = True
mode = 3
End If
TextBox1.Text = gl(1)
TextBox2.Text = gl(2)
TextBox3.Value = gl(3)
Pic1.BackColor = glc(4)
Pic2.BackColor = glc(7)
Pic3.BackColor = glc(10)
f1 = glf(13)
f2 = glf(16)
Label3.Text = gfinf(f1)
Label4.Text = gfinf(f2)
ComboBox1.SelectedIndex = gl(19)
OffsetDays.Value = CInt(gl(20))
Button8.PerformClick()
Catch ex As Exception
vis = True
Me.Visible = True
End Try
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim dlg As New ColorDialog
If dlg.ShowDialog = DialogResult.OK Then
Pic1.BackColor = dlg.Color
End If
End Sub
Private Sub Button5_Click(sender As Object, e As EventArgs) Handles Button5.Click
Dim dlg As New ColorDialog
If dlg.ShowDialog = DialogResult.OK Then
Pic2.BackColor = dlg.Color
End If
End Sub
Private Sub Button4_Click(sender As Object, e As EventArgs) Handles Button4.Click
Dim dlg As New ColorDialog
If dlg.ShowDialog = DialogResult.OK Then
Pic3.BackColor = dlg.Color
End If
End Sub
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim dlg As New OpenFileDialog
dlg.Filter = "All Picture Files|*.jpg;*.png;*.gif;*.bmp;*.tiff"
dlg.Title = "请选择一个图片"
If dlg.ShowDialog = DialogResult.OK And IO.File.Exists(dlg.FileName) Then
TextBox1.Text = dlg.FileName
End If
End Sub
Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
Dim dlg As New FolderBrowserDialog
If dlg.ShowDialog = DialogResult.OK Then
TextBox2.Text = dlg.SelectedPath
bmpindex = -1
End If
End Sub
Private Sub Button9_Click(sender As Object, e As EventArgs) Handles Button9.Click
s = ""
If RadioButton1.Checked Then
a(1)
ElseIf RadioButton2.Checked Then
a(2)
ElseIf RadioButton3.Checked Then
a(3)
End If
a(TextBox1.Text)
a(TextBox2.Text)
a(TextBox3.Text) ''shijian jiange
ac(Pic1) ''beijing
ac(Pic2) ''putong wenzi
ac(Pic3) ''daojishi wenzi
af(f1)
af(f2)
a(ComboBox1.SelectedIndex)
a(CInt(OffsetDays.Value))
IO.File.WriteAllText(Application.StartupPath & "\config", s)
End Sub
Sub a(s As String)
Me.s &= s & vbCrLf
End Sub
Private Sub Button6_Click(sender As Object, e As EventArgs) Handles Button6.Click
Dim dlg As New FontDialog
dlg.Font = f1
If dlg.ShowDialog() = DialogResult.OK Then
f1 = dlg.Font
Label3.Text = gfinf(f1)
End If
End Sub
Private Sub Button7_Click(sender As Object, e As EventArgs) Handles Button7.Click
Dim dlg As New FontDialog
dlg.Font = f2
If dlg.ShowDialog() = DialogResult.OK Then
f2 = dlg.Font
Label4.Text = gfinf(f2)
End If
End Sub
Sub ac(pic As PictureBox)
a(pic.BackColor.R)
a(pic.BackColor.G)
a(pic.BackColor.B)
End Sub
Sub af(f As Font)
a(f.FontFamily.Name)
a(f.Size)
a(f.Style)
End Sub
Function gl(i As Integer) As String
Return t.Lines(i)
End Function
Function glc(i As Integer) As Color
Return Color.FromArgb(gl(i), gl(i + 1), gl(i + 2))
End Function
Function glf(i As Integer) As Font
Dim stl As FontStyle = gl(i + 2)
Return New Font(gl(i), CInt(gl(i + 1)), stl)
End Function
<DllImport("user32.dll", EntryPoint:="SystemParametersInfo")>
Shared Function SystemParametersInfo(uAction As Integer, uParam As Integer, lpvParam As String, fuWinIni As Integer) As Integer
End Function
' Private Declare Ansi Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfo" (uAction As Integer, uParam As Integer, <MarshalAs(UnmanagedType.VBByRefStr)> ByRef lpvParam As String, fuWinIni As Integer) As Integer
Private Sub Button8_Click(sender As Object, e As EventArgs) Handles Button8.Click
size = Screen.PrimaryScreen.Bounds.Size
bmp = New Bitmap(size.Width, size.Height)
g = Graphics.FromImage(bmp)
Button9_Click(Nothing, Nothing)
Dim d As Date = Date.Now
Dim y As Integer
Dim dg As Date
Dim textpath As String
If (d.Date.Month = 6 And d.Date.Day >= 10) Or (d.Date.Month > 6) Then
y = d.Date.Year + 1
dg = New Date(y, 6, 7)
Else
y = d.Date.Year
dg = New Date(y, 6, 7)
End If
g.FillRectangle(New SolidBrush(Pic1.BackColor), Screen.PrimaryScreen.Bounds)
Dim bmp1 As Bitmap
If mode = 1 Then
GoTo H1
ElseIf mode = 2 Then
textpath = TextBox1.Text
Try
bmp1 = New Bitmap(textpath)
Catch ex As Exception
MsgBox("文件不存在！")
Exit Sub
End Try
ElseIf mode = 3 Then
Try
Dim interr = 0
H2: Dim list As ObjectModel.ReadOnlyCollection(Of String) '定义该路径下文件名的集合
list = My.Computer.FileSystem.GetFiles(TextBox2.Text)
Dim max As Integer = list.Count
bmpindex += 1
If bmpindex = max Then
bmpindex = 0
End If
textpath = list(bmpindex)
Try
bmp1 = New Bitmap(textpath)
Catch ex As Exception
interr += 1
If interr = max Then
MsgBox("文件夹下没有图片")
Exit Sub
End If
GoTo H2
End Try
Catch ex As Exception
MsgBox("文件夹不存在！")
Exit Sub
End Try
End If
Select Case ComboBox1.SelectedIndex
Case 0
g.DrawImage(bmp1, New PointF(0, 0))
Case 1
' g.FillRectangle(New SolidBrush(Pic1.BackColor), Screen.PrimaryScreen.Bounds)
If (bmp1.Width / bmp1.Height) < (size.Width / size.Height) Then
Dim k As Single = size.Height / bmp1.Height
Dim newh = size.Height
Dim neww = bmp1.Width * k
g.DrawImage(bmp1, New Rectangle((size.Width - neww) / 2, 0, neww, newh), New Rectangle(0, 0, bmp1.Width, bmp1.Height), GraphicsUnit.Pixel)
Else
Dim k As Single = size.Width / bmp1.Width
Dim newh = bmp1.Height * k
Dim neww = size.Width
g.DrawImage(bmp1, New Rectangle(0, (size.Height - newh) / 2, neww, newh), New Rectangle(0, 0, bmp1.Width, bmp1.Height), GraphicsUnit.Pixel)
End If
Case 2
g.DrawImage(bmp1, New Rectangle(New Point(0, 0), size), New Rectangle(0, 0, bmp1.Width, bmp1.Height), GraphicsUnit.Pixel)
Case 3
If (bmp1.Width / bmp1.Height) > (size.Width / size.Height) Then
Dim k As Single = size.Height / bmp1.Height
Dim newh = size.Height
Dim neww = bmp1.Width * k
g.DrawImage(bmp1, New Rectangle((size.Width - neww) / 2, 0, neww, newh), New Rectangle(0, 0, bmp1.Width, bmp1.Height), GraphicsUnit.Pixel)
Else
Dim k As Single = size.Width / bmp1.Width
Dim newh = bmp1.Height * k
Dim neww = size.Width
g.DrawImage(bmp1, New Rectangle(0, (size.Height - newh) / 2, neww, newh), New Rectangle(0, 0, bmp1.Width, bmp1.Height), GraphicsUnit.Pixel)
End If
End Select
H1: g.SmoothingMode = SmoothingMode.HighQuality
' Dim strsize As Size =
If d.Date.Month = 6 And (d.Date.Day = 7 Or d.Date.Day = 8 Or d.Date.Day = 9) Then
Dim p1 As Point = New Point((size.Width - GetStringSize("距 离 高 考 还 有", f1, New StringFormat(1)).Width) / 2, size.Height / 2 - 100)
Dim p2 As Point = New Point((size.Width - GetStringSize("0 天", f2, New StringFormat(1)).Width) / 2, p1.Y + GetStringSize("距 离 高 考 还 有", f1, New StringFormat(1)).Height)
g.DrawString("距 离 高 考 还 有", f1, New SolidBrush(Pic2.BackColor), p1)
g.DrawString("0 天", f2, New SolidBrush(Pic3.BackColor), p2)
Else
Dim days As Integer = Decimal.Ceiling((dg - d).TotalDays)
Dim stitle, sdays As String
Dim stk As Date
Dim stk1 As Date
For i = 1 To 31
stk = New Date(d.Year, 12, i)
If stk.DayOfWeek = DayOfWeek.Saturday Then
Label6.Text = "省统考系统生成的时间为：" & stk.ToString & " " & Format(stk, "ddd")
stk1 = stk.AddDays(CInt(OffsetDays.Value))
Label7.Text = "省统考自定义的时间为：" & stk1.ToString & " " & Format(stk, "ddd")
Exit For
End If
Next
If (d.Month = 6 And d.Day > 9) Or (d.Month = 12 And d.Day < stk1.Day) Or (d.Month > 6 And d.Month < 12) Then
stitle = "距 离 省 统 考 / 高 考 还 有"
sdays = Decimal.Ceiling((stk1 - d).TotalDays) & " / " & days & " 天"
Else
stitle = "距 离 高 考 还 有"
sdays = days & " 天"
OffsetDays.Value = 0
Button9_Click(Nothing, Nothing)
End If
Dim p1 As Point = New Point((size.Width - GetStringSize(stitle, f1, New StringFormat(1)).Width) / 2, size.Height / 2 - 100)
Dim p2 As Point = New Point((size.Width - GetStringSize(sdays, f2, New StringFormat(1)).Width) / 2, p1.Y + GetStringSize("距 离 高 考 还 有", f1, New StringFormat(1)).Height)
g.DrawString(stitle, f1, New SolidBrush(Pic2.BackColor), p1)
g.DrawString(sdays, f2, New SolidBrush(Pic3.BackColor), p2)
End If
Dim p3 As Point = New Point((size.Width - GetStringSize(Format(d, "yyyy年MM月dd日 ddd"), f1, New StringFormat(1)).Width) / 2, size.Height / 2 - GetStringSize(Format(d, "yyyy年MM月dd日 ddd"), f1, New StringFormat(1)).Height - 100)
g.DrawString(Format(d, "yyyy年MM月dd日 ddd"), f1, New SolidBrush(Pic2.BackColor), p3)
Dim x4 = (size.Width - GetStringSize(GetNongLi, f1, New StringFormat(1)).Width) / 2
Dim y4 = p3.Y - GetStringSize(GetNongLi, f1, New StringFormat(1)).Height
Dim p5 As Point = New Point(x4, y4)
g.DrawString(GetNongLi, f1, New SolidBrush(Pic2.BackColor), p5)
' g.DrawLine(New Pen(Color.Red, 1), New Point(0, 0), New Point(size.Width, 0))
Dim tinfo As String = "查看系统托盘以设置时间！v1.4"
Dim tfont As Font = New Font("楷体"， 20, FontStyle.Regular)
Dim p4 = New Point(size.Width - GetStringSize(tinfo, tfont, New StringFormat(1)).Width, 0)
g.DrawString(tinfo, tfont, New SolidBrush(Color.Red), p4)
'bmp.Save(Application.StartupPath & "\1.bmp")
'SystemParametersInfo(20, True, Application.StartupPath & "\1.bmp", 1)
Dim u As New Util
BackPlayer.Pic.Image = bmp
BackPlayer.Show()
u.SetAnimeBackground(BackPlayer.Handle)
GC.Collect()
End Sub
Function gfinf(f As Font) As String
Return "名称：" & f.FontFamily.Name & " 字号：" & f.Size & " 样式：" & f.Style.ToString
End Function
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
If MousePosition.Y = 0 Then
End If
If RadioButton3.Checked And Timer2.Enabled = False Then
Timer2.Enabled = True
Button9.PerformClick()
Timer2.Interval = CInt(TextBox3.Text) * 1000
ElseIf RadioButton3.Checked = False And Timer2.Enabled = True Then
Timer2.Enabled = False
Button9.PerformClick()
Timer2.Interval = CInt(TextBox3.Text) * 1000
End If
End Sub
Public Function GetStringSize(s As String, font As Font, sf As StringFormat) As Size
Dim size As New Size(CInt(g.MeasureString(s, font, 9999, sf).Width), CInt(g.MeasureString(s, font, 9999, sf).Height))
Return size
End Function
Private Sub Form1_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint
If vis = True Then
Me.Visible = True
Else
Me.Visible = False
End If
End Sub
Private Sub Button10_Click(sender As Object, e As EventArgs) Handles Button10.Click
Me.Close()
End Sub
Private Sub Form1_Closing(sender As Object, e As CancelEventArgs) Handles Me.Closing
e.Cancel = True
vis = False
Me.Visible = False
End Sub
Private Sub TextBox3_TextChanged(sender As Object, e As EventArgs)
Timer2.Interval = CInt(TextBox3.Text) * 1000
End Sub
Private Sub Timer2_Tick(sender As Object, e As EventArgs) Handles Timer2.Tick
Button8_Click(Nothing, Nothing)
End Sub
Private Sub Form1_DoubleClick(sender As Object, e As EventArgs) Handles Me.DoubleClick
If MsgBox("你确定要彻底退出吗？", vbYesNo, "高考倒计时") = MsgBoxResult.Yes Then
BackPlayer.Close()
Dim file As String = IO.Path.GetFileName(Process.GetCurrentProcess().MainModule.FileName)
Process.Start("cmd", "/c taskkill /f /im " & file)
End If
End Sub
Private Sub OffsetDays_ValueChanged(sender As Object, e As EventArgs) Handles OffsetDays.ValueChanged
Dim stk As Date
For i = 1 To 31
stk = New Date(Date.Now.Year, 12, i)
If stk.DayOfWeek = DayOfWeek.Saturday Then
Label6.Text = "省统考系统生成的时间为：" & stk.ToString & " " & Format(stk, "ddd")
Dim stk1 As Date = stk.AddDays(CInt(OffsetDays.Value))
Label7.Text = "省统考自定义的时间为：" & stk1.ToString & " " & Format(stk, "ddd")
Exit For
End If
Next
End Sub
Private Sub Button11_Click(sender As Object, e As EventArgs) Handles Button11.Click
Try
Helper.ShowDialog()
Catch ex As Exception
End Try
End Sub
Private Sub TextBox3_ValueChanged(sender As Object, e As EventArgs) Handles TextBox3.ValueChanged
Try
Timer2.Interval = CInt(TextBox3.Value) * 1000
Catch ex As Exception
End Try
End Sub
Private Sub RadioButton1_CheckedChanged(sender As Object, e As EventArgs) Handles RadioButton1.CheckedChanged
If RadioButton1.Checked Then
mode = 1
End If
End Sub
Private Sub RadioButton2_CheckedChanged(sender As Object, e As EventArgs) Handles RadioButton2.CheckedChanged
If RadioButton2.Checked Then
mode = 2
End If
End Sub
Private Sub RadioButton3_CheckedChanged(sender As Object, e As EventArgs) Handles RadioButton3.CheckedChanged
If RadioButton3.Checked Then
mode = 3
End If
End Sub
Private Sub Button9_MouseDown(sender As Object, e As MouseEventArgs) Handles Button9.MouseUp
MsgBox("保存成功！")
End Sub
Private Sub NotifyIcon1_Click(sender As Object, e As EventArgs) Handles NotifyIcon1.Click
End Sub
Private Sub 打开ToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles 打开ToolStripMenuItem.Click
vis = True
Me.Visible = True
TopMost = True
TopMost = False
End Sub
Private Sub 立即关闭ToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles 立即关闭ToolStripMenuItem.Click
Form1_DoubleClick(Nothing, Nothing)
End Sub
Private Sub NotifyIcon1_MouseClick(sender As Object, e As MouseEventArgs) Handles NotifyIcon1.MouseClick
If e.Button = MouseButtons.Left Then
vis = True
Me.Visible = True
TopMost = True
TopMost = False
ElseIf e.Button = MouseButtons.Right Then
End If
End Sub
Private Sub 帮助ToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles 帮助ToolStripMenuItem.Click
Button11_Click(Nothing, Nothing)
End Sub
End Class链接: https://pan.baidu.com/s/13N8Lm5SQJ9AMVd3bLrvrww?pwd=1234 提取码: 1234
关注我上传的文件CSDN，免费下载（需要有时间审核）