📄 frmmain.frm
字号:
VERSION 5.00
Begin VB.Form frmMain
Caption = "蓝雪万年历"
ClientHeight = 6405
ClientLeft = 165
ClientTop = 735
ClientWidth = 7485
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6405
ScaleWidth = 7485
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command2
Caption = "←"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 6960
TabIndex = 6
TabStop = 0 'False
Top = 0
Width = 255
End
Begin VB.CommandButton Command1
Caption = "↗"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 6720
TabIndex = 5
TabStop = 0 'False
Top = 0
Width = 255
End
Begin VB.Timer Timer2
Enabled = 0 'False
Interval = 1
Left = 5880
Top = 0
End
Begin VB.ComboBox Combo1
Height = 300
Left = 5880
Sorted = -1 'True
Style = 2 'Dropdown List
TabIndex = 4
Top = 817
Width = 1575
End
Begin VB.Timer Timer1
Interval = 1
Left = 3840
Top = 480
End
Begin VB.PictureBox picMain
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
Height = 5175
Left = 0
ScaleHeight = 341
ScaleMode = 3 'Pixel
ScaleWidth = 493
TabIndex = 3
Top = 1200
Width = 7455
End
Begin VB.PictureBox picToolbar
BorderStyle = 0 'None
Height = 255
Left = 4560
ScaleHeight = 255
ScaleWidth = 1215
TabIndex = 2
Top = 840
Width = 1215
Begin VB.Image Image2
Height = 240
Index = 4
Left = 960
Picture = "frmMain.frx":5C12
ToolTipText = "转到今天"
Top = 0
Width = 240
End
Begin VB.Image Image2
Height = 240
Index = 3
Left = 720
Picture = "frmMain.frx":6614
ToolTipText = "下一年"
Top = 0
Width = 240
End
Begin VB.Image Image2
Height = 240
Index = 2
Left = 480
Picture = "frmMain.frx":7016
ToolTipText = "下一月"
Top = 0
Width = 240
End
Begin VB.Image Image2
Height = 240
Index = 1
Left = 240
Picture = "frmMain.frx":7A18
ToolTipText = "上一月"
Top = 0
Width = 240
End
Begin VB.Image Image2
Height = 240
Index = 0
Left = 0
Picture = "frmMain.frx":841A
ToolTipText = "上一年"
Top = 0
Width = 240
End
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Label1"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 240
Left = 960
TabIndex = 0
Top = 360
Width = 810
End
Begin VB.Image Image1
Height = 720
Left = 120
Picture = "frmMain.frx":8E1C
Top = 120
Width = 720
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Label1"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00A0A0A0&
Height = 240
Left = 990
TabIndex = 1
Top = 390
Width = 810
End
Begin VB.Menu mnuCalendar
Caption = "日历(&C)"
Begin VB.Menu mnuCalendarLastYear
Caption = "上一年(&L)"
End
Begin VB.Menu mnuCalendarLastMonth
Caption = "上个月(&A)"
End
Begin VB.Menu mnuCalendarNextMonth
Caption = "下个月(&E)"
End
Begin VB.Menu mnuCalendarNextYear
Caption = "下一年(&N)"
End
End
Begin VB.Menu mnuView
Caption = "查看(&V)"
Begin VB.Menu mnuViewShowInfo
Caption = "显示日程信息(&S)"
Checked = -1 'True
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ======================
' 好软件，蓝蓝小雪造
' wz.bluesnow@gmail.com
' 502462725
' www.snow518.cn
' ======================
Option Explicit
Dim dateClass As New clsDate
Dim CanExit As Boolean
Dim oldWidth As Single
Dim oldHeight As Single
Dim curYear As Integer
Dim curMonth As Integer
Dim curDay As Integer
Dim tmpA As Single
Dim tmpB As Single
Dim tmpC As Single
Dim BI As Variant
Dim BI2 As Variant
Dim BI3 As Variant
Dim BI4 As Variant
Dim BI5 As Variant
Dim BI6 As Variant
Dim HideInfo As Boolean
Dim bool(0 To 1) As Boolean
Private Sub Combo1_Change()
Me.picMain.FontName = Me.Combo1.List(Me.Combo1.ListIndex)
ReDrawCalendar
End Sub
Private Sub Combo1_Click()
Combo1_Change
End Sub
Private Sub Command1_Click()
Static status As Boolean
Static oldW As Single, oldH As Single
If status = False Then
oldW = Me.Width
oldH = Me.Height
Me.Width = Screen.Width / 20 * 17 - IIf(HideInfo, 0, frmInfo.Width)
Me.Height = Screen.Height / 20 * 17
status = True
Me.Command1.Caption = "↙"
Else
Me.Width = oldW
Me.Height = oldH
status = False
oldW = 0
oldH = 0
Me.Command1.Caption = "↗"
End If
Me.Left = (Screen.Width - Me.Width - IIf(HideInfo, 0, frmInfo.Width)) / 2
Me.Top = (Screen.Height - Me.Height) / 2
Me.picMain.SetFocus
End Sub
Private Sub Command1_GotFocus()
If bool(0) = False Then Me.picMain.SetFocus
End Sub
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
bool(0) = True
End Sub
Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
bool(0) = False
End Sub
Private Sub Command2_Click()
If frmInfo.Visible = True Then
frmInfo.Visible = False
HideInfo = True
Me.Command2.Caption = "→"
Else
frmInfo.Visible = True
HideInfo = False
Me.Command2.Caption = "←"
End If
Me.Left = (Screen.Width - Me.Width - IIf(HideInfo, 0, frmInfo.Width)) / 2
Me.Top = (Screen.Height - Me.Height) / 2
Me.picMain.SetFocus
End Sub
Private Sub Command2_GotFocus()
If bool(1) = False Then Me.picMain.SetFocus
End Sub
Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
bool(1) = True
End Sub
Private Sub Command2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
bool(1) = False
End Sub
Private Sub Form_Load()
BI = Split(StrConv(LoadResData(101, "CUSTOM"), vbUnicode), vbCrLf)
BI2 = Split(StrConv(LoadResData(102, "CUSTOM"), vbUnicode), vbCrLf)
BI3 = Split(StrConv(LoadResData(103, "CUSTOM"), vbUnicode), vbCrLf)
BI4 = Split(StrConv(LoadResData(104, "CUSTOM"), vbUnicode), vbCrLf)
BI5 = Split(StrConv(LoadResData(105, "CUSTOM"), vbUnicode), vbCrLf)
BI6 = Split(StrConv(LoadResData(106, "CUSTOM"), vbUnicode), vbCrLf)
Load frmInfo
frmInfo.Show
oldWidth = Me.Width
oldHeight = Me.Height
curYear = Year(Date$)
curMonth = Month(Date$)
curDay = Day(Date$)
Me.mnuCalendarLastMonth.Caption = Me.mnuCalendarLastMonth.Caption & vbTab & "Page Up"
Me.mnuCalendarNextMonth.Caption = Me.mnuCalendarNextMonth.Caption & vbTab & "Page Up"
Show
Me.Left = (Screen.Width - Me.Width - IIf(HideInfo, 0, frmInfo.Width)) / 2
Me.Top = (Screen.Height - Me.Height) / 2
Me.SetFocus
Dim i As Integer
Me.Combo1.Enabled = False
CanExit = False
Dim strName As String
For i = 0 To Screen.FontCount - 1
strName = Screen.Fonts(i)
If Me.Timer2.Enabled = False Then frmInfo.Caption = "↙ 正在处理字体……" & Format(i + 1) & "/" & Format(Screen.FontCount)
If Me.Timer2.Enabled = True And i Mod 50 = 0 Then Me.Timer2.Enabled = False
Select Case LCase(strName)
Case "wingdings", "wingdings 2", "wingdings 3", "webdings", "symbol", "simplified arabic bold", "simplified arabic fixed", "simplified arabic", "rod", "pmingliu", "pmingliu-extb", "narkisim", "mv boli", "mt extra", "ms reference sans serif", "ms reference specialty"
Case "ms outlook", "ms mincho", "ms pmincho", "ms gothic", "ms pgothic", "ms ui gothic", "aharoni", "arabic typesetting", "arabic transparent", "bookshelf symbol 7", "david"
Case Else
If Left(LCase(strName), 15) = "times new roman" And Len(strName) <> 15 Then
ElseIf Left(LCase(strName), 5) = "arial" And Len(strName) <> 5 Then
ElseIf Left(LCase(strName), 11) = "courier new" And Len(strName) <> 11 Then
ElseIf Left(LCase(strName), 7) = "mingliu" Then
ElseIf Left(strName, 1) = "@" Then
ElseIf Left(strName, 2) = "方正" Then
ElseIf Left(strName, 2) = "华文" Then
ElseIf Right(strName, 4) = "Bold" Then
ElseIf Right(strName, 6) = "-18030" Then
ElseIf Left(strName, 2) = "MS" Then
Else
Me.Combo1.AddItem strName
End If
End Select
DoEvents
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -