请教

weiyulin 2009-06-23 11:26:14

我放了一个　窗口　在　Shell_TrayWnd　的 TrayClockWClass 位置　　并隐藏了以前的　时间Lable

我现在要做的事情是,　将该窗体设置为全透明的（以显示主题背景） 然后在窗体上面　绘制 文本


我怎样才能实现这样的功能

谢谢
...全文
43 12 打赏 收藏 转发到动态 举报
写回复
用AI写文章
12 条回复
切换为时间正序
请发表友善的回复…
发表回复
weiyulin 2009-06-24
  • 打赏
  • 举报
 回复
以下代码 运行时 不会出错，但没有效果反应出来

窗体:
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
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 Const GWL_STYLE = (-16)
Private Const WS_CHILD = &H40000000
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRECT As RECT) 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
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, ByVal lpPoint As Long) As Long
Private Sub Form_Load()


aaa '做个标识 不知道哪里出错,自定义函数过程

Dim rtClock As RECT
Dim hwndTray As Long, hwndNotify As Long, hwndClock As Long
Me.ScaleMode = vbPixels
hwndTray = FindWindow("Shell_TrayWnd", vbNullString)
hwndNotify = FindWindowEx(hwndTray, 0, "TrayNotifyWnd", vbNullString)
hwndClock = FindWindowEx(hwndNotify, 0, "TrayClockWClass", vbNullString)
If hwndClock = 0 Then Exit Sub
SetWindowLong Me.hWnd, GWL_STYLE, GetWindowLong(Me.hWnd, GWL_STYLE) Or WS_CHILD
SetParent Me.hWnd, hwndTray
GetWindowRect hwndClock, rtClock
ScreenToClient hwndTray, VarPtr(rtClock.Left)
ScreenToClient hwndTray, VarPtr(rtClock.Right)
MoveWindow Me.hWnd, rtClock.Left, rtClock.Top, rtClock.Right - rtClock.Left, rtClock.Bottom - rtClock.Top, 1
LabTime.Caption = Format(Time, "hh:mm:ss")
LabDate.Caption = Right(Year(Date), 2) & "." & Format(Month(Date), "00") & "." & Format(Day(Date), "00")
'年份只提取前两位,月和日一样

End Sub

Private Sub Form_DblClick()
MsgBox "关闭窗口"
Unload Me
End Sub


模块:


Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As Long

Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As Long

Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As _
Long, lpPoint As POINTAPI) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Const RGN_AND = 1
Const RGN_COPY = 5
Const RGN_DIFF = 4
Const RGN_OR = 2
Const RGN_XOR = 3

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



Sub DataSamp()
Dim ad As Database
Dim aserch As QueryDef


End Sub

Public Sub MakeTransparent(frm As Form)
Dim rctClient As RECT, rctFrame As RECT
Dim hClient As Long, hFrame As Long

'获得窗口矩形区域
GetWindowRect frm.hWnd, rctFrame
GetClientRect frm.hWnd, rctClient

'将窗口矩形坐标转换为屏幕坐标
Dim lpTL As POINTAPI, lpBR As POINTAPI
lpTL.x = rctFrame.Left
lpTL.Y = rctFrame.Top
lpBR.x = rctFrame.Right
lpBR.Y = rctFrame.Bottom
ScreenToClient frm.hWnd, lpTL
ScreenToClient frm.hWnd, lpBR
rctFrame.Left = lpTL.x
rctFrame.Top = lpTL.Y
rctFrame.Right = lpBR.x
rctFrame.Bottom = lpBR.Y
rctClient.Left = Abs(rctFrame.Left)
rctClient.Top = Abs(rctFrame.Top)
rctClient.Right = rctClient.Right + Abs(rctFrame.Left)
rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)
rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)
rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)
rctFrame.Top = 0
rctFrame.Left = 0


hClient = CreateRectRgn(rctClient.Left, rctClient.Top, rctClient.Right, rctClient.Bottom)
hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, rctFrame.Right, rctFrame.Bottom)

CombineRgn hFrame, hClient, hFrame, RGN_XOR

SetWindowRgn frm.hWnd, hFrame, True
End Sub

Public Sub aaa()
MakeTransparent ForSysTray_time
End Sub

weiyulin 2009-06-24
  • 打赏
  • 举报
 回复
以下是我的代码，功能是 显示一个窗体 并在 系统右下角 显示 (遮住系统默认的lable)
但是运行时 出错


Option Explicit


Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As _
Long, lpRECT As RECT) As Long

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As _
Long, lpRECT As RECT) As Long

Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long



Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Const RGN_AND = 1
Const RGN_COPY = 5
Const RGN_DIFF = 4
Const RGN_OR = 2
Const RGN_XOR = 3

Public 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 Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, ByVal lpPoint As Long) As Long




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 WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
'************************************************
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 Const GWL_STYLE = (-16)
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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Const WS_CHILD = &H40000000
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent 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





Private Sub Form_DblClick()
For_SysTray_Time_Option.Show
End Sub

Private Sub Form_Load()

Dim rtClock As RECT
Dim hwndTray As Long, hwndNotify As Long, hwndClock As Long
Me.ScaleMode = vbPixels
hwndTray = FindWindow("Shell_TrayWnd", vbNullString)
hwndNotify = FindWindowEx(hwndTray, 0, "TrayNotifyWnd", vbNullString)
hwndClock = FindWindowEx(hwndNotify, 0, "TrayClockWClass", vbNullString)
If hwndClock = 0 Then Exit Sub
SetWindowLong Me.hwnd, GWL_STYLE, GetWindowLong(Me.hwnd, GWL_STYLE) Or WS_CHILD
SetParent Me.hwnd, hwndTray
GetWindowRect hwndClock, rtClock
ScreenToClient hwndTray, VarPtr(rtClock.Left)
ScreenToClient hwndTray, VarPtr(rtClock.Right)
MoveWindow Me.hwnd, rtClock.Left, rtClock.Top, rtClock.Right - rtClock.Left, rtClock.Bottom - rtClock.Top, 1
LabTime.Caption = Format(Time, "hh:mm:ss")
LabDate.Caption = Right(Year(Date), 2) & "." & Format(Month(Date), "00") & "." & Format(Day(Date), "00")
'年份只提取前两位,月和日一样



MakeTransparent Me



Me.Show

End Sub

Private Sub LabDate_DblClick()
For_SysTray_Time_Option.Show
End Sub

Private Sub LabTime_DblClick()

For_SysTray_Time_Option.Show

End Sub

Private Sub Timer_SysTray_Time_Timer()

LabTime.Caption = Format(Time, "hh:mm:ss")

'显示时间
LabDate.Caption = Right(Year(Date), 2) & "." & Format(Month(Date), "00") & "." & Format(Day(Date), "00")
'年份只提取前两位,月和日一样


End Sub



Sub DataSamp()
Dim ad As Database
Dim aserch As QueryDef


End Sub

Public Sub MakeTransparent(frm As Form)

Dim rctClient As RECT, rctFrame As RECT
Dim hClient As Long, hFrame As Long

'获得窗口矩形区域
GetWindowRect frm.hwnd, rctFrame
GetClientRect frm.hwnd, rctClient

'将窗口矩形坐标转换为屏幕坐标
Dim lpTL As POINTAPI, lpBR As POINTAPI
lpTL.x = rctFrame.Left
lpTL.Y = rctFrame.Top
lpBR.x = rctFrame.Right
lpBR.Y = rctFrame.Bottom
ScreenToClient frm.hwnd, lpTL
ScreenToClient frm.hwnd, lpBR
rctFrame.Left = lpTL.x
rctFrame.Top = lpTL.Y
rctFrame.Right = lpBR.x
rctFrame.Bottom = lpBR.Y
rctClient.Left = Abs(rctFrame.Left)
rctClient.Top = Abs(rctFrame.Top)
rctClient.Right = rctClient.Right + Abs(rctFrame.Left)
rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)
rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)
rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)
rctFrame.Top = 0
rctFrame.Left = 0


hClient = CreateRectRgn(rctClient.Left, rctClient.Top, rctClient.Right, rctClient.Bottom)
hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, rctFrame.Right, rctFrame.Bottom)

CombineRgn hFrame, hClient, hFrame, RGN_XOR

SetWindowRgn frm.hwnd, hFrame, True
End Sub
舉杯邀明月 2009-06-23
  • 打赏
  • 举报
 回复
[Quote=引用 2 楼 chen8013 的回复:]
估计你的窗体不应该用 Alpha 来设置透明，而应该使用 KeyColor 来设置透明。
这样，文字只需要输入到自己的窗体上就可以了，刷新内容比较方便，并且应该不会造成桌面花屏。

[/Quote]
文字只需要输入到自己的窗体上就可以了　　===>
文字只需要输出到自己的窗体上就可以了
舉杯邀明月 2009-06-23
  • 打赏
  • 举报
 回复
估计你的窗体不应该用 Alpha 来设置透明，而应该使用 KeyColor 来设置透明。
这样，文字只需要输入到自己的窗体上就可以了，刷新内容比较方便，并且应该不会造成桌面花屏。
神马都能聊 2009-06-23
  • 打赏
  • 举报
 回复
意思是将文本绘制后显示到桌面上?还是哪个窗体,没看明白
weiyulin 2009-06-23
  • 打赏
  • 举报
 回复

不好意思，我刚学VB 不知道什么Keycolor
能否给我具体的代码 严重感谢
舉杯邀明月 2009-06-23
  • 打赏
  • 举报
 回复
[Quote=引用 7 楼 weiyulin 的回复:]
 
  谢谢 toury 的回复  我下班后测试你的代码


    我的意思是说：用自己的窗口 替换 系统 的时间显示(就是TrayClockWClass，任务栏右下角)  然后在我的窗体中显示文本

      现在遇到一个问题，如果当系统主题改变，我怎么把我的窗口背景改成 任务栏 底纹一样的颜色或者图片  这就是我的问题 （我想的是 把我的窗体 设置为透明 但楼上又有老师 说 如果设置成透明 就不能输出文本了）  随便说一下，不一定要print或用什么场景绘制的方法  也可以用label控件显示
[/Quote]

我在 2F 的回复没看？还是没明白？
如果通过 Alpha 使窗体全透明，你输出到窗体上的文字也是全透明的，当然就什么也看不到。
用 KeyColor 来设置透明，只要文字颜色与 KeyColor 不一样就行了。

设置 KeyColor 透明参考 5F 的代码。
贝隆 2009-06-23
  • 打赏
  • 举报
 回复
学习
weiyulin 2009-06-23
  • 打赏
  • 举报
 回复

谢谢 toury 的回复 我下班后测试你的代码


我的意思是说：用自己的窗口 替换 系统 的时间显示(就是TrayClockWClass，任务栏右下角) 然后在我的窗体中显示文本

现在遇到一个问题，如果当系统主题改变，我怎么把我的窗口背景改成 任务栏 底纹一样的颜色或者图片 这就是我的问题 （我想的是 把我的窗体 设置为透明 但楼上又有老师 说 如果设置成透明 就不能输出文本了） 随便说一下，不一定要print或用什么场景绘制的方法 也可以用label控件显示
toury 2009-06-23
  • 打赏
  • 举报
 回复
对不起，忘记最重要的一点哈
Private Sub Form_Load()
BackColor = &HFF0000'加上这句！！
。。。。。。
toury 2009-06-23
  • 打赏
  • 举报
 回复 


Option Explicit



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 WM_NCLBUTTONDOWN = &HA1

Private Const HTCAPTION = 2

'************************************************

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 Const GWL_STYLE = (-16)

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 Sub Command1_Click()

  End

End Sub



Private Sub Form_Load()

  Font = "黑体"

  ForeColor = &HFF&

  FontSize = 72

  CurrentX = 500

  CurrentY = 1000

  Me.Print "我爱你，中国！"

  Dim rtn As Long

  rtn = GetWindowLong(hWnd, GWL_EXSTYLE) '取窗口原先的样式

  rtn = rtn Or WS_EX_LAYERED             '使窗体添加上新的样式WS_EX_LAYERED

  SetWindowLong hWnd, GWL_EXSTYLE, rtn   '把新的样式赋给窗体

  SetLayeredWindowAttributes hWnd, &HFF0000, 0, &H1

  Me.Refresh

End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

   Dim nRet1, nRet2

   nRet1 = ReleaseCapture

   nRet2 = SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)

End Sub


简单写了一下，这样可以吗？
lyserver 2009-06-23
  • 打赏
  • 举报
 回复
透明窗口上不能输出文字,可以使用异形窗口代替,即把文字作为窗口,也可以使用屏幕绘图方式代替.
ThinkPHP5生成二维码及背景图片合成
二维码是我们在开发网站和项目的时候经常遇到的，我第一次接触二维码时，翻过许多资料，也请教许多所谓高人，被整的还是一头雾水，于是自己下决心一定搞明白二维码到底怎么回事，在经历许多坑，花费许多时间和精力后终于明白了，二维码真实情况，为了让大家少走弯路，避免各种坑，节约大家成本和时间，特制作此课程，让你彻底明白二维码的生成过程。
英文邮件礼仪：向教授请教学术问题
英文邮件礼仪：向教授请教学术问题   邮件主题 邮件主题（subject）不需要写自己的名字。名字是在邮件系统设置里设定好的，在发件时会替换显示实际地址，所以无需在主题里再写一遍。 [关键内容是要在主题里就写明白是否有推荐人，以及主要是什么事。很多教授只看主题。]   一个好的标题，要能简洁地概括邮件的目的或内容。如果你对教授的某个研究项目感兴趣，就可以用这个研究方向作标题，例如"De
请教神牛p1337
题目 ：请教神牛 描述 Description： HZGD神牛是个非常牛B的人,每天都有人来向他请教问题.但是他有原则.同一个人不能在一个学期内请教他两次,并且他每天只见一个请教者, 无论他以前是否请教过,否则他就没时间去干其他事情了,嘿嘿(坏笑…就是不见宁智贤).于是,现在的问题就是,神牛并不是总记得每一个人.所以,你需要写一个程序帮助他判断每天接见的那个人是否请教过. 输入格式 Input ...
向别人请教问题，不要这样开头
前言 我们经常会有请教别人问题的时候，而下面这几种是不太建议的提问开头 在吗？ 能问你一个问题吗？ 有谁知道xxx吗？ 当然你向我提问的时候，也不用称呼为大佬或者大神之类的，我就是一个普通的开发者。 为什么 毋庸置疑，你提问的目的自然是想得到解答，而上面三种提问方式都有一个共性，就是在看到上面的问题之后，仍然不知道具体问题是什么，而要简单回复之后才能得到真...
曾国藩家书-修身篇 致诸弟·明师益友虚心请教
曾国藩家书-修身篇 致诸弟·明师益友虚心请教感悟参考资料 感悟 本文1中对“格物”和“诚意”两个概念做了诠释，值得深究。 然则既自名为读书人，则《大学》之纲领皆己立身切要之事明矣。其修目有八，自我观之，其致功之处，则仅二者而已，曰格物，曰诚意。格物，致知之事也。诚意，力行之事也。物者何？即所谓本末之物也。身心意知家国天下，皆物也。天地万物，皆物也。日用常行之事，皆物也。格者，即格物而穷其理也。如事...
API

1,486

社区成员

23,279

社区内容

发帖
与我相关
我的任务
社区描述
VB API
社区管理员
  • API
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章