frmalert.frm

adsl拨号工具 有很多功能 不错啊 大家试试

VERSION 5.00
Begin VB.Form frmAlert 
   BorderStyle     =   3  'Fixed Dialog
   ClientHeight    =   1635
   ClientLeft      =   45
   ClientTop       =   45
   ClientWidth     =   4635
   ControlBox      =   0   'False
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1635
   ScaleWidth      =   4635
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer tmrOpen 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   2160
      Top             =   600
   End
   Begin VB.Timer tmrClose 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   2160
      Top             =   1080
   End
   Begin VB.PictureBox picBackground 
      AutoRedraw      =   -1  'True
      Height          =   1560
      Left            =   0
      Picture         =   "frmAlert.frx":0000
      ScaleHeight     =   1500
      ScaleWidth      =   4530
      TabIndex        =   0
      Top             =   0
      Width           =   4590
      Begin VB.Image Image1 
         Height          =   480
         Left            =   270
         Picture         =   "frmAlert.frx":1D95
         Top             =   105
         Width           =   480
      End
      Begin VB.Label lblAlert 
         BackStyle       =   0  'Transparent
         ForeColor       =   &H000000FF&
         Height          =   720
         Left            =   315
         TabIndex        =   1
         Top             =   705
         Width           =   4035
      End
   End
   Begin VB.Timer tmrAlert 
      Enabled         =   0   'False
      Interval        =   30000
      Left            =   2160
      Top             =   120
   End
End
Attribute VB_Name = "frmAlert"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉出品
'发布日期：05/08/15
'描  述：拨号上网管理器
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************

Private Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex As Long)
Private Declare Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Const SM_CXFULLSCREEN = 16   ' 窗口区宽度
Const SM_CYFULLSCREEN = 17   ' 窗口区高度
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10

'渐变色背景
'Private ClsGradient As New CGradient
Private fX As Long
Private fY As Long
Private lngScaleX As Long
Private lngScaleY As Long
Private AlertIndex As Long

Private Sub Form_Unload(Cancel As Integer)
   EndPlaySound
End Sub

Private Sub lblAlert_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '显示链接
    If lblAlert.FontUnderline = False Then
        lblAlert.FontUnderline = True
        lblAlert.ForeColor = RGB(0, 0, 255)
    End If
End Sub

Private Sub picBackground_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' 显示文本
    If lblAlert.FontUnderline = True Then
        lblAlert.FontUnderline = False
        lblAlert.ForeColor = &H0
    End If
End Sub

Private Sub tmrAlert_Timer()
    tmrAlert.Enabled = False
    tmrClose.Enabled = True
End Sub

Private Sub tmrClose_Timer()
    Dim curHeight As Long
    curHeight = Me.Height
    If curHeight > 120 Then
        Me.Height = curHeight - 30
        Me.Top = Me.Top + 30
    Else
        ' 关闭窗口
        If AlertCount = AlertIndex Then AlertCount = 0
        Unload Me
    End If
End Sub

'打开动画
Private Sub tmrOpen_Timer()
    Dim curHeight As Long
    Dim newHeight As Long
    curHeight = Me.Height
    If curHeight < picBackground.Height + lngScaleY Then
        newHeight = curHeight + 30
        If newHeight > picBackground.Height + lngScaleY Then newHeight = picBackground.Height + lngScaleY
        Me.Height = Me.Height + (newHeight - curHeight)
        Me.Top = Me.Top - (newHeight - curHeight)
    Else
        tmrOpen.Enabled = False
        tmrAlert.Enabled = True
    End If
   '窗口置前
End Sub

Public Sub DisplayAlert(MessageText As String, Duration As Long)

    Dim wFlags As Long, X As Long

    ' Increase the alert count
    AlertCount = AlertCount + 1
    AlertIndex = AlertCount

    ' 设置信息
    lblAlert.Caption = MessageText

    tmrAlert.Interval = Duration

    ' 系统单位
    fX = GetSystemMetrics(SM_CXFULLSCREEN)
    fY = GetSystemMetrics(SM_CYFULLSCREEN)
    lngScaleX = Me.Width - Me.ScaleWidth
    lngScaleY = Me.Height - Me.ScaleHeight
    
    '窗口大小
    Me.Height = 90
    Me.Width = picBackground.Width + lngScaleX
    Me.Left = fX * Screen.TwipsPerPixelX - Me.Width
    Me.Top = (fY * Screen.TwipsPerPixelY) - ((picBackground.Height + lngScaleY) * (AlertCount - 1)) + 160
    Me.Show
    
    ' 播放声音,最好从资源文件中播放
    'wFlags = SND_ASYNC Or SND_NODEFAULT
    'X = sndPlaySound(App.Path & "\newalert.wav", wFlags)
    BeginPlaySound 103
    ' 渐变背景
    'With ClsGradient
    '    .Angle = 130
        '.Color1 = RGB(255, 255, 255)
        '.Color2 = RGB(128, 230, 255)
        
    '    .Color1 = RGB(255, 255, 255)
    '    .Color2 = RGB(Int(Rnd * 200), Int(Rnd * 300), 255)
    '    .Draw picBackground
    'End With
    'picBackground.Refresh

    tmrOpen.Enabled = True
End Sub