📄 adbar.frm
字号:
VERSION 5.00
Begin VB.Form ADbar
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H00C0E0FF&
BorderStyle = 0 'None
Caption = "Form3"
ClientHeight = 1335
ClientLeft = 0
ClientTop = 0
ClientWidth = 4710
DrawWidth = 2
LinkTopic = "Form3"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1335
ScaleWidth = 4710
ShowInTaskbar = 0 'False
Begin VB.Timer Timer2
Left = 2760
Top = 480
End
Begin VB.CommandButton CmdEnd
Height = 495
Left = 3360
TabIndex = 7
Top = 120
Width = 135
End
Begin VB.CommandButton CmdFirst
Height = 255
Left = 0
Picture = "ADbar.frx":0000
Style = 1 'Graphical
TabIndex = 3
Top = 0
Width = 375
End
Begin VB.PictureBox ADPic
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 300
Index = 1
Left = 0
ScaleHeight = 270
ScaleWidth = 4680
TabIndex = 4
Top = 720
Width = 4710
Begin VB.CommandButton CmdBut
Height = 495
Index = 1
Left = 0
TabIndex = 5
Top = 0
Width = 90
End
Begin VB.Image ImgLogo
Height = 495
Index = 1
Left = 240
Picture = "ADbar.frx":0576
Stretch = -1 'True
Top = 0
Width = 495
End
Begin VB.Label ADtext
BackStyle = 0 'Transparent
Caption = "欢迎光临天下网吧！这是一个wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww虐在"
ForeColor = &H00FFFFFF&
Height = 255
Index = 1
Left = 840
TabIndex = 6
Top = 120
Width = 2535
End
End
Begin VB.Timer Timer1
Left = 4800
Top = 120
End
Begin VB.PictureBox ADPic
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 300
Index = 0
Left = 840
Picture = "ADbar.frx":0AEC
ScaleHeight = 270
ScaleWidth = 4680
TabIndex = 0
Top = 0
Width = 4710
Begin VB.CommandButton CmdBut
Height = 495
Index = 0
Left = 0
TabIndex = 1
Top = 0
Width = 90
End
Begin VB.Image ImgLogo
Height = 495
Index = 0
Left = 240
Picture = "ADbar.frx":4CFE
Stretch = -1 'True
Top = 0
Width = 495
End
Begin VB.Label ADtext
BackStyle = 0 'Transparent
Caption = "欢迎光临天下网吧！这是一个wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww虐在"
ForeColor = &H00FFFFFF&
Height = 255
Index = 0
Left = 120
TabIndex = 2
Top = 120
Width = 3735
End
End
End
Attribute VB_Name = "ADbar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'获得窗口在屏幕坐标中的位置
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'判断指定的点是否在指定的巨型内部
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long) As Long
'准备用来使窗体始终在最前面
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
'用来移动窗体
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
'使窗口总是在屏幕的最前面
Const HWND_TOPMOST = -1
'鼠标坐标
Private Type POINTAPI
X As Long
Y As Long
End Type
'窗口形状
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private MyRect As RECT
Private MyPoint As POINTAPI
Private MyADcount, MaxCount As Long
'配置文件所在文件路径
Private iniPath As String
Private Entry As String
'广告文字的移动速度，加大Move_Step的值使速度变快
Const Move_Step = 1
Const Text_Step = 32
Private Sub ADtext_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'Debug.Print Index, X, Y
'Timer1.Enabled = False
End Sub
'缩小窗口
Private Sub CmdEnd_Click()
Me.WindowState = 1
End Sub
'退出
Private Sub CmdFirst_Click()
Dim i
i = MsgBox("您要关闭消息条吗？", vbOKCancel, "传奇科技")
If i = 1 Then Unload Me
End Sub
Private Sub Form_Load()
On Error GoTo ErrCode1:
'设定坐标系为象素
Me.ScaleMode = 3
ADPic(0).ScaleMode = 3
ADPic(1).ScaleMode = 3
'ImgLogo(0).Visible = False
'ImgLogo(1).Visible = False
'调整窗口大小和位置
Me.Width = Me.Width - Move_Step * Screen.TwipsPerPixelX
'Debug.Print Me.Width, Move_Step * Screen.TwipsPerPixelX * 2
Me.Height = 20 * Screen.TwipsPerPixelY
Me.Top = 0
Me.Left = Screen.Width / 12
'调整广告条前面的图标按钮大小和位置
CmdFirst.Height = Me.ScaleHeight
CmdFirst.Left = 0
CmdFirst.Width = CmdFirst.Height
CmdFirst.Top = 0
'调整广告条后面的最小化按钮的大小和位置
CmdEnd.Height = Me.ScaleHeight
CmdEnd.Left = Me.ScaleWidth - CmdEnd.Width
CmdEnd.Top = 0
'设定广告条中第一个滚动文字栏的初始大小和位置
ADPic(0).Left = -Move_Step
ADPic(0).Top = Me.ScaleTop
CmdBut(0).Height = ADPic(0).ScaleHeight
'设定第一个滚动文字栏中，图标的初始大小和位置
ImgLogo(0).Top = ADPic(0).Top + 2
ImgLogo(0).Width = 15
ImgLogo(0).Height = 15
ImgLogo(0).Left = CmdBut(0).Left + CmdBut(0).Width + 3
'设定第一个滚动文字栏中，广告文字的初始大小和位置
ADtext(0).Top = Me.ScaleTop + 4
ADtext(0).Left = ImgLogo(0).Left + ImgLogo(0).Width + 3
ADtext(0).Width = ADPic(0).Width - CmdBut(0).Width - ImgLogo(0).Width - 20
'设定第一次的广告文字的内容
ADtext(0).Caption = "=================欢迎光临！=================="
Debug.Print ADtext(0).Width, LenB(StrConv("Internet Explorer 将许多功能引入 Windows 桌面：", vbFromUnicode))
ADPic(1).Left = Me.ScaleWidth
ADPic(1).Top = Me.ScaleTop
CmdBut(1).Height = ADPic(1).ScaleHeight
'设定第二个滚动文字栏中，图标的初始大小和位置
ImgLogo(1).Top = ADPic(1).Top + 2
ImgLogo(1).Width = 15
ImgLogo(1).Height = 15
ImgLogo(1).Left = CmdBut(1).Left + CmdBut(1).Width + 3
'设定第二个滚动文字栏中，广告文字的初始大小和位置
ADtext(1).Top = Me.ScaleTop + 4
ADtext(1).Left = ImgLogo(1).Left + ImgLogo(1).Width + 3
ADtext(1).Width = ADPic(1).Width - CmdBut(1).Width - ImgLogo(1).Width - 20
'设定第二次的广告文字的内容
ADtext(1).Caption = "这里有许多有趣的消息，敬请关注！"
'使广告条窗口总是位于屏幕的最前面
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
Me.Height \ Screen.TwipsPerPixelY, 0
'保存广告条窗口的大小和位置，用于感应鼠标指向广告条时暂停滚动
Dim dl&
dl& = GetWindowRect(Me.hwnd, MyRect)
'用来控制广告文字的滚动
Timer1.Interval = 50
Timer1.Enabled = True
'用来感应鼠标指向广告条的动作
Timer2.Interval = 500
Timer2.Enabled = True
'初始化当前广告条数
MyADcount = 0
'设定配置文件（广告条内容）路径
iniPath$ = App.Path + "\SysSet.ini"
'读取广告条数量
MaxCount = Val(GetFromINI("滚动广告条", "数量", iniPath))
Debug.Print "aa", MaxCount
Exit Sub
ErrCode1:
MsgBox "传奇网吧伴侣滚动广告条无法正常启动，请重新下载或安装！", , "滚动广告条启动出错"
Unload Me
End Sub
Private Sub Timer1_Timer()
'移动广告条
If ADPic(0).Left > Me.ScaleLeft - Me.ScaleWidth Then
'如果广告条一超过窗口（即左边界完全超出窗口范围）
ADPic(0).Left = ADPic(0).Left - Move_Step
Else
ADPic(0).Left = Me.ScaleWidth
'读入广告语
If MyADcount < MaxCount Then
ADtext(0).Caption = GetFromINI("滚动广告条", "广告词" + Str(MyADcount), iniPath)
MyADcount = MyADcount + 1
Else
MyADcount = 0
End If
End If
'控制广告条的移动，如果广告条完全超出了窗口的可视范围，就从头再来。
If Me.ScaleWidth - ADPic(0).Left >= ADPic(0).Width Or ADPic(1).Left <> Me.ScaleWidth Then
If ADPic(1).Left > Me.ScaleLeft - Me.ScaleWidth Then
ADPic(1).Left = ADPic(1).Left - Move_Step '没有超出，继续左移广告词
Else
ADPic(1).Left = Me.ScaleWidth
If MyADcount < MaxCount Then '读取广告词
ADtext(1).Caption = GetFromINI("滚动广告条", "广告词" + Str(MyADcount), iniPath)
MyADcount = MyADcount + 1
Else
MyADcount = 0
End If
End If
End If
End Sub
Private Sub Timer2_Timer()
Dim dl&
'得到当前鼠标的坐标
dl& = GetCursorPos(MyPoint)
'PtInRect()判断，如果返回值=0，则当前坐标在广告条窗口的范围之外
If PtInRect(MyRect, MyPoint.X, MyPoint.Y) = 0 Then
' Debug.Print "out"
Timer1.Enabled = True
Else
' Debug.Print "in"
'在广告条窗口内，暂停timer1控件，广告语不再滚动。
Timer1.Enabled = False
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -