frmadscreen.frm

传奇网吧伴侣源码

VERSION 5.00
Begin VB.Form frmADScreen 
   BorderStyle     =   0  'None
   Caption         =   "frmADScreen"
   ClientHeight    =   4845
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   7890
   LinkTopic       =   "Form1"
   ScaleHeight     =   4845
   ScaleWidth      =   7890
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   WindowState     =   2  'Maximized
   Begin VB.TextBox Text1 
      Height          =   495
      Left            =   1080
      TabIndex        =   2
      Text            =   "Text1"
      Top             =   3720
      Visible         =   0   'False
      Width           =   1695
   End
   Begin VB.Timer Timer1 
      Interval        =   1000
      Left            =   2280
      Top             =   2520
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "上饶传奇设计荣誉出品"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   18
         Charset         =   134
         Weight          =   700
         Underline       =   -1  'True
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   375
      Index           =   1
      Left            =   3550
      TabIndex        =   1
      Top             =   360
      Width           =   3975
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "上饶传奇设计荣誉出品"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   18
         Charset         =   134
         Weight          =   700
         Underline       =   -1  'True
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C0FFFF&
      Height          =   375
      Index           =   0
      Left            =   3600
      TabIndex        =   0
      Top             =   360
      Width           =   3975
   End
End
Attribute VB_Name = "frmADScreen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private iniPath As String
Dim strADText(3) As String


Private Sub ShowText()
    Dim C As Long
    Dim strText As String
    Dim dl As Long
    
    Dim TextDC As Long
    Dim hTextBmp As Long
    
    Dim TextSize As SIZE
    Dim X As Long
    Dim Y As Long
    Static Index As Integer
    
   ' me.Picture = Image1.Picture
    
    '创建一个设备场景
    TextDC = CreateCompatibleDC(Me.hDC)
    hTextBmp = CreateCompatibleBitmap(Me.hDC, Me.ScaleWidth, 80)
    dl& = SelectObject(TextDC, hTextBmp)
    
    PatBmp TextDC                '用实体画刷填充设备
    SelectFont TextDC, "黑体"
    '循环播放广告词动画
    Select Case Index
           Case 0
                 SetTextColor TextDC, vbGreen
                'Debug.Print Len(GetFromINI("电脑空闲时广告词", "第一句", iniPath))
                 strText = strADText(0)
           Case 1
                 SetTextColor TextDC, vbBlue
                 strText = strADText(1)
           Case 2
                 SetTextColor TextDC, vbCyan
                 strText = strADText(2)
                 'Me.Refresh
           Case 3
                 SetTextColor TextDC, vbRed
                 strText = strADText(3)
    End Select
    
          Index = Index + 1
    If Index = 4 Then
    Index = 0
    Me.Refresh
    End If
    PaintText TextDC, strText

    C = GetPixel(TextDC, 0, 0)
    TransBlt Me.hDC, 0, 100 + Index * 100, Me.ScaleWidth, 50, TextDC, 0, 0, C

    
End Sub





Private Sub Form_Load()
On Error GoTo ErrCode2:
    Dim hDC As Long, sx As Integer, sy As Integer

    Me.ScaleMode = vbPixels
   ' me.Picture = Image1.Picture
    
    Me.Hide
    DoEvents
    
    '窗口自动刷新
    Me.AutoRedraw = True
    '获得桌面句柄
    hDC = GetDC(0)
    '获得屏幕大小
    sx = Screen.Width \ Screen.TwipsPerPixelX
    sy = Screen.Height \ Screen.TwipsPerPixelY
    '将桌面载入到当前窗口中，使屏幕达到透明效果
    BitBlt Me.hDC, 0, 0, sx, sy, hDC, 0, 0, vbSrcCopy
    ReleaseDC 0, hDC
    '禁止窗口自动刷新
    Me.AutoRedraw = False
    
    'SetPicture
    Me.Show
    '调整两个Label的位置，达到阴影效果
    Label1(0).Left = Me.ScaleWidth - 300
    Label1(1).Left = Label1(0).Left - 1
    Label1(1).Top = Label1(0).Top - 1
    '设定配置文件路径
    iniPath$ = App.Path + "\SysSet.ini"
    '检测配置文件是否存在                                                                '设置广告词，通过TEXT1来把单字节转为汉字的双字节
    If Dir(iniPath) <> "" Then
    '有配置文件，开始读取"电脑空亲时广告词"
        Text1.Text = GetFromINI("电脑空闲时广告词", "第一句", iniPath)
        strADText(0) = Text1.Text '用text1进行字符转换，是我发明的旁门左道，有其它办法可以换
        
        'MsgBox Len(strADText(0))
        
        Text1.Text = GetFromINI("电脑空闲时广告词", "第二句", iniPath)
        strADText(1) = Text1.Text
        
        Text1.Text = GetFromINI("电脑空闲时广告词", "第三句", iniPath)
        strADText(2) = Text1.Text
        
        Text1.Text = GetFromINI("电脑空闲时广告词", "第四句", iniPath)
        strADText(3) = Text1.Text

    Else
    '没有配置文件，就载入默认广告词
        strADText(0) = "传奇科技"
        '        MsgBox Len(strADText(0))

        strADText(1) = "科技提高效率，技术改变生活！"
        strADText(2) = "欢迎光临！"
        strADText(3) = "本机空闲"

    End If
    '广告动画速度控制，速度为二秒
    Timer1.Interval = 2000
    Timer1.Enabled = True
    
Exit Sub
ErrCode2:
MsgBox "传奇网吧伴侣气空闲广告词窗口无法正常启动，请查看设置空闲广告词或重新下载安装！", , "空闲广告词窗口启动出错"
Unload Me

End Sub



Private Sub Timer1_Timer()
'在屏幕上播放广告词
ShowText
End Sub