date.frm

可以计算今天到指定日期之间的天数,如2009-01-01

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form DateForm 
   Appearance      =   0  'Flat
   BorderStyle     =   0  'None
   Caption         =   "Date"
   ClientHeight    =   1650
   ClientLeft      =   105
   ClientTop       =   105
   ClientWidth     =   2505
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   Icon            =   "Date.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   1650
   ScaleWidth      =   2505
   ShowInTaskbar   =   0   'False
   Begin MSComDlg.CommonDialog FontCommonDialog 
      Left            =   3360
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label ContentLabel 
      Alignment       =   2  'Center
      Caption         =   "0"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   975
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   1575
   End
   Begin VB.Menu OptionMenu 
      Caption         =   "Option"
      Visible         =   0   'False
      Begin VB.Menu SetFont 
         Caption         =   "字体(&T)"
      End
      Begin VB.Menu Setting 
         Caption         =   "设置...(&S)"
      End
      Begin VB.Menu line1 
         Caption         =   "-"
      End
      Begin VB.Menu Exit 
         Caption         =   "退出(&X)"
      End
   End
End
Attribute VB_Name = "DateForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'拖放窗口移动
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
'窗口坐标
Dim Window_X, Window_Y

'背景透明
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1

'窗体最前
Private Declare Function SetWindowPos Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long _
) As Long

'hWndInsertAfter的值
Const HWND_BOTTOM = 1   '将窗口置于Z序列的底部
Const HWND_TOP = 0      '将窗口置于Z序列的顶部
Const HWND_TOPMOST = -1     '将窗口置于顶部,并位于最顶窗口的前面
Const HWND_NOTOPMOST = -2   '将窗口置于顶部,并位于最顶窗口的后面

'wFlags的值
Const SWP_HIDEWINDOW = &H80 '隐藏窗口
Const SWP_NOACTIVE = &H10   '不激活窗口
Const SWP_NOMOVE = &H2      '保持窗口当前位置(x,y设定将被忽略)
Const SWP_NOREDRAW = &H8    '窗口不自动重画
Const SWP_NOSIZE = &H1      '保持窗口当前大小(cx,cy设定将被忽略)
Const SWP_NOZORDER = &H8    '保持窗口列表在当前的位置(hWndInsertAfter设定将被忽略)
Const SWP_SHOWWINDOW = &H40 '显示窗口




Private Sub Form_Load()
    'On Error Resume Next
    Me.Caption = ""
    App.TaskVisible = False
    '窗体透明
    Dim BgColor As String
    BgColor = &H0 '&H646464 '&HFF00F0  '指定需要透明的控件或窗体的背景颜色
    Me.BackColor = BgColor
    ContentLabel.BackColor = BgColor
    Dim rtn As Long
    rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
    rtn = rtn Or WS_EX_LAYERED
    SetWindowLong hwnd, GWL_EXSTYLE, rtn
    SetLayeredWindowAttributes hwnd, BgColor, 0, LWA_COLORKEY '让背景色透明!!
     
 '设置窗口位置
    Call ReadPos
    Call SetWindowPos(Me.hwnd, HWND_TOP, Window_X, Window_Y, 0, 0, SWP_NOSIZE + SWP_SHOWWINDOW)
    
    
'加载字体设置
    Call loadFont
'加载日期设置
    Call SetDate
End Sub

'字体设置
Function loadFont()

    ContentLabel.Font.Name = GetSetting("Data.exe", "Font", "Name", "宋体")
    ContentLabel.Font.Size = GetSetting("Data.exe", "Font", "Size", 18)
    ContentLabel.Font.Bold = GetSetting("Data.exe", "Font", "Bold", 1)
    ContentLabel.Font.Italic = GetSetting("Data.exe", "Font", "Italic", 0)
    ContentLabel.Font.Underline = GetSetting("Data.exe", "Font", "Underline", 0)
    ContentLabel.FontStrikethru = GetSetting("Data.exe", "Font", "FontStrikethru", 0)
    ContentLabel.ForeColor = GetSetting("Data.exe", "Font", "ForeColor", vbYellow)

    FontCommonDialog.FontName = ContentLabel.Font.Name
    FontCommonDialog.FontSize = ContentLabel.Font.Size
    FontCommonDialog.FontBold = ContentLabel.Font.Bold
    FontCommonDialog.FontItalic = ContentLabel.Font.Italic
    FontCommonDialog.FontUnderline = ContentLabel.Font.Underline
    FontCommonDialog.FontStrikethru = ContentLabel.FontStrikethru
    FontCommonDialog.Color = ContentLabel.ForeColor
    
End Function

'日期设置
Function SetDate()
    On Error Resume Next
    Dim Date2
    Date2 = GetSetting("Data.exe", "Date", "Year", 2009)
    Date2 = Date2 + "-" + GetSetting("Data.exe", "Date", "Month", 1)
    Date2 = Date2 + "-" + GetSetting("Data.exe", "Date", "day", 1)
    Date2 = CDate(Date2)
    ContentLabel = DateDiff("Y", Date, Date2)
    
    ContentLabel.Width = ContentLabel.Font.Size * 45
    ContentLabel.Height = ContentLabel.Font.Size * 22.5
    Me.Width = ContentLabel.Width
    Me.Height = ContentLabel.Height
End Function

Private Sub SetFont_Click()
    '将 Cancel 设置成 True。
    FontCommonDialog.CancelError = False
    On Error GoTo ErrHandler
    '设置 Flags 属性。
    FontCommonDialog.Flags = cdlCFBoth Or cdlCFEffects
    '显示“字体”对话框。
    FontCommonDialog.ShowFont
    '根据用户的选择来设置
    '文本属性。
    ContentLabel.Font.Name = FontCommonDialog.FontName
    ContentLabel.Font.Size = FontCommonDialog.FontSize
    ContentLabel.Font.Bold = FontCommonDialog.FontBold
    ContentLabel.Font.Italic = FontCommonDialog.FontItalic
    ContentLabel.Font.Underline = FontCommonDialog.FontUnderline
    ContentLabel.FontStrikethru = FontCommonDialog.FontStrikethru
    If FontCommonDialog.Color = 0 Then FontCommonDialog.Color = 16
    ContentLabel.ForeColor = FontCommonDialog.Color
    
    Call SaveSetting("Data.exe", "Font", "Name", ContentLabel.Font.Name)
    Call SaveSetting("Data.exe", "Font", "Size", ContentLabel.Font.Size)
    Call SaveSetting("Data.exe", "Font", "Bold", ContentLabel.Font.Bold)
    Call SaveSetting("Data.exe", "Font", "Italic", ContentLabel.Font.Italic)
    Call SaveSetting("Data.exe", "Font", "Underline", ContentLabel.Font.Underline)
    Call SaveSetting("Data.exe", "Font", "FontStrikethru", ContentLabel.FontStrikethru)
    Call SaveSetting("Data.exe", "Font", "ForeColor", ContentLabel.ForeColor)
    Call SetDate
    Exit Sub
    
ErrHandler:
    '用户按了“取消”按钮。
    Exit Sub

End Sub

'拖放窗口移动
Private Sub ContentLabel_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
        '保存位置
        Call WritePos
    End If
End Sub

'读取窗口位置
Private Function ReadPos()
    Window_X = GetSetting("Data.exe", "Window", "X", 200)
    Window_Y = GetSetting("Data.exe", "Window", "Y", 100)
End Function

'保存窗口位置
Private Function WritePos()
    Call SaveSetting("Data.exe", "Window", "X", Me.Left / 15)
    Call SaveSetting("Data.exe", "Window", "Y", Me.Top / 15)
End Function

'右键菜单
Private Sub ContentLabel_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub

Private Sub Setting_Click()
    DialogSetting.Show
End Sub

'退出
Private Sub Exit_Click()
    Unload DialogSetting
    Unload Me
End Sub