|
- 帖子
- 40
- 积分
- 334
- 技术
- 2
- 捐助
- 0
- 注册时间
- 2009-2-1
|
26楼
发表于 2013-1-28 22:10
| 只看该作者
VERSION 5.00
Begin VB.Form TipBall
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 0 'None
Caption = "气泡"
ClientHeight = 3600
ClientLeft = 0
ClientTop = 0
ClientWidth = 4800
ClipControls = 0 'False
ControlBox = 0 'False
Enabled = 0 'False
FillColor = &H80000005&
FillStyle = 0 'Solid
FontTransparent = 0 'False
ForeColor = &H80000005&
HasDC = 0 'False
Icon = "气泡主体.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
Moveable = 0 'False
NegotiateMenus = 0 'False
ScaleHeight = 3600
ScaleMode = 0 'User
ScaleWidth = 4800
ShowInTaskbar = 0 'False
Visible = 0 'False
End
Attribute VB_Name = "TipBall"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'托盘API 模块
Private M_IconData As NOTIFYICONDATA
Private Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 128
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End Type
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
'使用高分辨率图标所用的API
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long '延迟API
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '避免延迟时CPU使用率过高 Sleep API
Dim CountStrC As Integer
'统计参数个数
Dim Strcmd '参数拆分后的数组
Dim Info, TitleAndKind, Title, TipKinds, Start_Pro As String
'内容 标题与提示种类 标题 提示种类 点击运行
Dim Hide_Start As Boolean '是否隐藏启动点击运行
Dim TrayIcon '用于存高分辨率图标
Dim SleepT '延迟时间
Dim Begintime As Double '记录当前时间
Private Sub Form_Load()
Me.Hide '无窗口
On Error GoTo EndPor '防止拖拽(如果参数类型不对则结束程序)
If InStr(Command, ";;") <> "0" Then '如果参数不为空 则
Strcmd = Split(Command, ";;") '拆分所有参数
CountStrC = UBound(Strcmd) - LBound(Strcmd) + 1 '获取参数 数目
Dim Tmp As String, i '自定义延迟 时 获取延迟时间
For i = 1 To Len(Strcmd(0)) '只获取数字
Tmp = Mid(Strcmd(0), i, 1)
If Asc(Tmp) <= Asc("9") And Asc(Tmp) >= Asc("0") Then SleepT = SleepT & Tmp
Next
If CountStrC >= "2" Then '如果有标题 则
If Strcmd(1) <> "" Then '如果标题不为空 则
If InStr(Strcmd(1), "#@") <> "0" Then '如果指定了标题类型 则
TitleAndKind = Split(Strcmd(1), "#@") '拆分标题 与 标题类型 参数 并存入 数组
Title = TitleAndKind(0) '获取标题
'设定提示类型
If TitleAndKind(1) = "0" Then
TipKinds = &H0 '无标题图标
Else
If TitleAndKind(1) = "1" Then
TipKinds = &H7 '询问标题图标
Else
If TitleAndKind(1) = "2" Then
TipKinds = &H2 '感叹标题图标
Else
If TitleAndKind(1) = "3" Then
TipKinds = &H3 '错误标题图标
Else
If TitleAndKind(1) = "4" And CountStrC >= "5" Then If Trim(Strcmd(4)) <> "" Then TipKinds = &H4 '当设定了 托盘图标与4时，设定标题图标 同 托盘图标
End If
End If
End If
End If
Else
Title = Strcmd(1) '没指定类型时 直接 获取标题
End If
Else '如果标题为空 则
TipKinds = &H0 '无提示类型
End If
If CountStrC >= "3" Then
Info = Replace((Strcmd(2)), "\n", vbCrLf) '获取内容 并 转义"\n"回车符
If CountStrC >= "4" Then '如果有点击后 运行的命令
If InStr(Strcmd(3), "##") <> "0" Or InStr(Strcmd(3), "##") <> "0" Then '如果指定为隐藏运行 获取命令路径 并 删除 ##
Start_Pro = Replace(Strcmd(3), "##", "")
Hide_Start = True
Else
Start_Pro = Trim(Strcmd(3)) '否则直接 获取点击后 运行的命令
End If
If CountStrC >= "5" Then
TrayIcon = LoadImage(App.hInstance, Trim(Strcmd(4)), 1, 16, 16, &H10 Or &H1000) '先检测图标文件是否存在 如存在自定义托盘图标
If Trim(Strcmd(4)) <> "" Then If TrayIcon = "0" Then GoTo TrayIcoHelp '如果托盘ICO 文件类型不对 则提示错误
End If
End If
End If
If Info = "" Then '如果内容为空 则 提示错误
Info = "提示内容应不为空"
Show_Error '调用错误 处理
End If
End If
Else '如果参数里不含分号 则
If Command = "" Then '如果参数为空 则 显示参数格式
Title = "气泡 调用参数 "
Info = "[时间];;[标题[#@标题图标]];;内容;;" & vbCrLf & "[点击后执行的命令[##]];;[托盘图标路径]" & vbCrLf & vbCrLf & "正键 点击我 查看参数详细说明"
SleepT = 20000
Else '如果有参数 但参数没包含分号
Info = "请键入 参数分隔符" & vbCrLf & "参数分隔符为两个西文半角的 分号"
Show_Error '调用错误 处理
End If
End If
Begintime = timeGetTime '记下开始时的时间
While timeGetTime < Begintime + 2600 '循环等待原托盘 退出
Por_Num = 0 '初始化 进程 数值
Call EnumWindows(AddressOf EnumWindowsProc, 0) ' 检测是否有新的 调用
If Por_Num < 2 Then Tip_Show '调用气泡
Sleep 3 '避免延迟时CPU使用率过高
DoEvents '转让控制权，以便让操作系统处理其它的事件。
Wend
'################## 以下为错误 处理 #####################
EndPor: End '防止拖拽 (注意这行不可改变位置与删除,须接在循环等待后面)
TrayIcoHelp: Info = "自定义托盘图标参数错误" & vbCrLf & "所指定的不是 .Ico文件"
Show_Error '调用错误 处理
'################## 以上为错误 处理 #####################
End Sub
Private Sub Show_Error() '错误处理
'初始化错误参数
Title = "参数错误！"
TipKinds = &H3
SleepT = 0
Start_Pro = ""
Tip_Show '调用气泡 显示错误信息
End Sub
Private Sub Tip_Show()
With M_IconData
.cbSize = Len(M_IconData)
.hwnd = Me.hwnd
.uID = vbNull
.uFlags = &H2 Or &H10 Or &H1 Or &H4 '设定托盘图标、提示图标、信息栏
.uCallbackMessage = &H200
.hIcon = TrayIcon '托盘图标
.szTip = "气泡提示" & vbNullChar
.dwState = 0
.dwStateMask = 0
If SleepT = 0 Then SleepT = 7000 '有参数时的 默认延迟
.uTimeout = SleepT
.szInfo = Info + Chr(0) '内容
.szInfoTitle = Title + Chr(0) '标题
If TipKinds = "" Then TipKinds = &H1 '当标题图标为空时 设定 标题图标为 普通标题图标
.dwInfoFlags = TipKinds '提示类型
End With
Shell_NotifyIcon &H0, M_IconData '创建托盘图标
'调用延迟
Begintime = timeGetTime '记下开始时的时间
While timeGetTime < Begintime + SleepT '循环等待
Por_Num = 0 '初始化 进程 数值
Call EnumWindows(AddressOf EnumWindowsProc, 0) ' 检测是否有新的 调用
If Por_Num >= 2 Then Tip_Exit '调用退出
Sleep 2 '避免延迟时CPU使用率过高
DoEvents '转让控制权，以便让操作系统处理其它的事件。
Wend
Tip_Exit '调用退出
End Sub
Private Sub Tip_Exit()
Shell_NotifyIcon &H2, M_IconData '删除托盘图标
End '退出程序
End Sub
'鼠标事件
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim cEvent As Single
cEvent = x / Screen.TwipsPerPixelX
Select Case cEvent
Case 512
'Debug.Print "MouseMove"
Case 1026
'Debug.Print "气泡显示"
Case 1028 '右键点击或关闭气泡
Tip_Exit '调用退出
Case 1029 '左键或中键点击气泡
If Title = "气泡 调用参数 " Then
Dim TxtHelp As String
TxtHelp = vbCrLf & vbCrLf
TxtHelp = TxtHelp & "参数格式:" & vbCrLf & "[ShowsTime];;[Title[#@TitleIcoType]];;Text;;[ClickRun_FilePath[##]];;[TrayIco_FilePath]" & vbCrLf & vbCrLf
TxtHelp = TxtHelp & "ShowsTime 气泡显示时间 单位Ms" & vbCrLf
TxtHelp = TxtHelp & "Text 内容(支持 \n 回车转义符)" & vbCrLf
TxtHelp = TxtHelp & "Title 标题" & vbCrLf
TxtHelp = TxtHelp & "TitleIcoType 标题图标类型 0:无图标、1:询问图标、2:感叹图标、3:错误图标、4:同托盘图标" & vbCrLf
TxtHelp = TxtHelp & "ClickRun_FilePath 鼠标正键点击气泡后 运行的外部程序" & vbCrLf
TxtHelp = TxtHelp & "## 无窗口运行点击气泡后的外部程序" & vbCrLf
TxtHelp = TxtHelp & "TrayIco_FilePath 自定义托盘图标文件路径 (支持XP样式的 .Ico图标!)" & vbCrLf & vbCrLf
TxtHelp = TxtHelp & "注: ""[ ]"" 中为可选参数、参数分隔符为两个西文半角的分号" & vbCrLf & vbCrLf & vbCrLf
TxtHelp = TxtHelp & "各项参数的缺省值: 标题图标为提示图标、显示7000ms、无托盘图标、无点击气泡后执行的命令" & vbCrLf & vbCrLf & vbCrLf
TxtHelp = TxtHelp & "调用举例:" & vbCrLf
TxtHelp = TxtHelp & """程序路径"" 9000;;凌枫工作组#@2;;By T_kaven\nQQ群:35962310\n\n点击我 打开记事本;;%Windir%\Notepad.exe"
MsgBox TxtHelp, 65536, "参数详细说明 (点击确定后 本帮助会自动复制到剪切板)"
Clipboard.Clear '清除剪贴板
Clipboard.SetText TxtHelp '将帮助文本传送到剪贴板
Info = "By T_kaven" & vbCrLf & "QQ群:35962310" & vbCrLf & vbCrLf & "点击我 打开记事本"
Title = "凌枫工作组"
SleepT = 9000
TipKinds = &H2 '感叹提示
Start_Pro = Environ$("windir") & "\Notepad.exe"
Shell_NotifyIcon &H2, M_IconData '删除托盘图标
Tip_Show '调用气泡
Else
If Start_Pro <> "" Then '如果有点击后的命令则
On Error Resume Next '如果找不到 文件 则忽略(不检测文件是否存在 用于支持带参数运行)
If Hide_Start = True Then
Shell (Start_Pro), vbHide '如果 Hide_Start = True 隐藏运行
Else
Shell (Start_Pro), vbNormalFocus '否则 正常运行
End If
End If
End If
Tip_Exit '调用退出
End Select
End Sub |
|
发表于 2012-11-21 14:05
| 
发表于 2012-11-22 03:33
| 