设置窗体透明但是窗体上的图片不透明...网上的好多都是骗人的...

evjen 2008-12-22 04:51:20
网上的代码:

Option Explicit

'设置透明窗体
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
Dim sty As Long

sty = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
sty = sty Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, sty
SetLayeredWindowAttributes Me.hwnd, 0, 200, LWA_ALPHA


这些代码 是控件和窗体一起透明了...
希望各位大侠有没有更好的解决方法 最好有例子 并测试成功...
...全文
281 10 打赏 收藏 转发到动态 举报
写回复
用AI写文章
10 条回复
切换为时间正序
请发表友善的回复…
发表回复
ZOUYONG0929 2008-12-25
  • 打赏
  • 举报
回复
两个控件A,B.
A遮蔽了B
A透明
B的改变能在A里看到吗?
lyserver 2008-12-24
  • 打赏
  • 举报
回复
再添加一个功能,让窗口透明但窗口背景图片不透明(此效果只针对图片小于窗口的效果明显)
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_OR = 2
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

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

Private Sub Form_Click()
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Long, ctl As Object, hRgn As Long, tRgn As Long, nLeft As Long, nTop As Long
Dim rc As RECT, pt(1) As POINTAPI

Set Me.Picture = LoadPicture("c:\1936_1.jpg")
Me.ScaleMode = vbPixels
nLeft = Me.Left \ Screen.TwipsPerPixelX
nTop = Me.Top \ Screen.TwipsPerPixelY

For i = 0 To Me.Controls.Count - 1
Set ctl = Me.Controls(i)
pt(0).x = ctl.Left - nLeft
pt(0).y = ctl.Top - nTop
pt(1).x = pt(0).x + ctl.Width
pt(1).y = pt(0).y + ctl.Height
ClientToScreen Me.hwnd, pt(0)
ClientToScreen Me.hwnd, pt(1)
tRgn = CreateRectRgn(pt(0).x, pt(0).y, pt(1).x, pt(1).y)
If hRgn = 0 Then
hRgn = tRgn
Else
CombineRgn hRgn, hRgn, tRgn, RGN_OR
DeleteObject tRgn
End If
Next
'让背景图片不透明
pt(0).x = -nLeft
pt(0).y = -nTop
pt(1).x = Me.ScaleX(Me.Picture.Width, vbHimetric, vbPixels) + pt(0).x
pt(1).y = Me.ScaleY(Me.Picture.Height, vbHimetric, vbPixels) + pt(0).y
ClientToScreen Me.hwnd, pt(0)
ClientToScreen Me.hwnd, pt(1)
tRgn = CreateRectRgn(pt(0).x, pt(0).y, pt(1).x, pt(1).y)
If hRgn = 0 Then
hRgn = tRgn
Else
CombineRgn hRgn, hRgn, tRgn, RGN_OR
DeleteObject tRgn
End If
SetWindowRgn Me.hwnd, hRgn, True
DeleteObject hRgn
End Sub
zzyong00 2008-12-24
  • 打赏
  • 举报
回复
[Quote=引用 5 楼 lyserver 的回复:]
这是俺以前回答的半透明控件的例子:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private D…
[/Quote]
不错,顶顶
lyserver 2008-12-24
  • 打赏
  • 举报
回复
这是我刚才写的窗口透明控件不透明的代码,未使用常见的SetLayeredWindowAttributes函数。
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_OR = 2
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

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

Private Sub Form_Click()
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Long, ctl As Object, hRgn As Long, tRgn As Long, nLeft As Long, nTop As Long
Dim rc As RECT, pt(1) As POINTAPI

Me.ScaleMode = vbPixels
nLeft = Me.Left \ Screen.TwipsPerPixelX
nTop = Me.Top \ Screen.TwipsPerPixelY

For i = 0 To Me.Controls.Count - 1
Set ctl = Me.Controls(i)
pt(0).x = ctl.Left - nLeft
pt(0).y = ctl.Top - nTop
pt(1).x = pt(0).x + ctl.Width
pt(1).y = pt(0).y + ctl.Height
ClientToScreen Me.hwnd, pt(0)
ClientToScreen Me.hwnd, pt(1)
tRgn = CreateRectRgn(pt(0).x, pt(0).y, pt(1).x, pt(1).y)
If hRgn = 0 Then
hRgn = tRgn
Else
CombineRgn hRgn, hRgn, tRgn, RGN_OR
DeleteObject tRgn
End If
Next
SetWindowRgn Me.hwnd, hRgn, True
DeleteObject hRgn
End Sub
嗷嗷叫的老马 2008-12-24
  • 打赏
  • 举报
回复
顶顶!
lyserver 2008-12-24
  • 打赏
  • 举报
回复
这是俺以前回答的半透明控件的例子:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
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 Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_SHOW = 5
Private Const SW_HIDE = 0

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean

Dim m_hMemDC As Long
Dim m_hMemBmp As Long, m_hMemBmpPrev As Long
Dim m_rcControl As RECT

Private Sub UserControl_Initialize()
UserControl.AutoRedraw = True
m_hMemDC = CreateCompatibleDC(UserControl.hdc)
End Sub

Private Sub UserControl_Terminate()
If m_hMemBmp <> 0 Then
DeleteObject SelectObject(m_hMemDC, m_hMemBmpPrev)
End If
DeleteDC m_hMemDC
End Sub

Public Sub Translucence()
Dim hdc As Long
Dim tPt As POINTAPI

'获得控件当前位置和大小
ClientToScreen UserControl.hwnd, tPt
ScreenToClient UserControl.ContainerHwnd, tPt
Call GetClientRect(UserControl.hwnd, m_rcControl)
OffsetRect m_rcControl, tPt.X, tPt.Y
'创建一幅内存位图
If m_hMemBmp <> 0 Then
DeleteObject (SelectObject(m_hMemDC, m_hMemBmpPrev))
End If
m_hMemBmp = CreateCompatibleBitmap(UserControl.hdc, m_rcControl.Right, m_rcControl.Bottom)
m_hMemBmpPrev = SelectObject(m_hMemDC, m_hMemBmp)

'隐藏控件
ShowWindow UserControl.hwnd, SW_HIDE
DoEvents

'保存控件容器的图像到内存位图中
Dim hDesktopDC As Long
hDesktopDC = GetDC(UserControl.hwnd)
BitBlt m_hMemDC, 0, 0, m_rcControl.Right, m_rcControl.Bottom, hDesktopDC, 0, 0, vbSrcCopy
ReleaseDC 0, hDesktopDC

'通过alpha效果进行半透明渲染
UserControl.AutoRedraw = True
AlphaBlend m_hMemDC, 0, 0, m_rcControl.Right, m_rcControl.Bottom, UserControl.hdc, 0, 0, m_rcControl.Right, m_rcControl.Bottom, 5242880
UserControl.AutoRedraw = False

'显示控件
ShowWindow UserControl.hwnd, SW_SHOW

'将渲染后的结果复制到控件中
BitBlt UserControl.hdc, 0, 0, m_rcControl.Right, m_rcControl.Bottom, m_hMemDC, 0, 0, vbSrcCopy
End Sub

Private Sub UserControl_Paint()
BitBlt UserControl.hdc, 0, 0, m_rcControl.Right, m_rcControl.Bottom, m_hMemDC, 0, 0, vbSrcCopy
End Sub

调用代码如下:
Private Sub Form_Activate()
Me.UserControl11.Translucence
End Sub
ZOUYONG0929 2008-12-22
  • 打赏
  • 举报
回复
以前我也想要 窗体透明 控件不透明 网上找了好多.最终结果是不可能实现.(模拟方法除外)
ZOUYONG0929 2008-12-22
  • 打赏
  • 举报
回复
要的是半透明就难办点
要的是完全透明就好办了 窗体背景色 和 SetLayeredWindowAttributes Me.hwnd, "窗体背景色", 0, LWA_COLORKEY
那你的控件就不透明了
如果半透明的话 LWA_ALPHA 那是没办法的 XP是没办法实现的
不过有个替代的办法 不过CPU挺累
设置完全透明+半透明窗体 +Hook
还有 窗体+picuture(有句柄的都行) 不是说用BItbit 实时拷贝背景 那样好像也难办 是用Setparent 不过有麻烦 坐标系统乱了(我想了N久都没想出个办法解决)
jy497759649 2008-12-22
  • 打赏
  • 举报
回复
http://dl4.csdn.net/fd.php?i=58677838249577&s=5ddaf8d8c082c7feca68648a54653526
ftz820127 2008-12-22
  • 打赏
  • 举报
回复
色红为异形窗口的屏蔽色255,0,0


Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'hwnd ----------- Long,欲为其取得信息的窗口的句柄
'nIndex --------- Long,请参考GetWindowLong函数的nIndex参数的说明
'dwNewLong ------ Long,由nIndex指定的窗口信息的新值

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'hwnd ----------- Long,欲为其获取信息的窗口的句柄
'nIndex --------- Long,欲取回的信息,可以是下述任何一个常数:
'GWL_EXSTYLE
'扩展窗口样式
'GWL_STYLE
'窗口样式
'GWL_WNDPROC
'该窗口的窗口函数的地址
'GWL_HINSTANCE
'拥有窗口的实例的句柄
'GWL_HWNDPARENT
'该窗口之父的句柄?不要用SetWindowWord来改变这个值
'GWL_ID
'对话框中一个子窗口的标识符
'GWL_USERDATA
'含义由应用程序规定
'DWL_DLGPROC
'这个窗口的对话框函数地址
'DWL_MSGRESULT
'在对话框函数中处理的一条消息返回的值
'DWL_USER
'含义由应用程序规定

Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'hwnd --透明窗体的句柄
'crKey --为颜色值
'bAlpha -- 透明度,取值范围是[0,255]
'dwFlags -- 透明方式,可以取两个值:当取值为LWA_ALPHA时,crKey参数无效,
'bAlpha参数有效;当取值为LWA_COLORKEY时,bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明

Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20) '窗体扩展式样
Const LWA_COLORKEY = &H1 '关键颜色(异形窗体)
Const LWA_ALPHA = &H2 '透明度
Const LWA_COLORKEY_ALPHA = &H3 '透明 + 异形

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

Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1

Private Sub Command1_Click()
End
End Sub

Private Sub Form_Load()
Dim NewStyle As Long '窗体的新式样
Dim WinStyle As Long '记录窗体原来的式样
WinStyle = GetWindowLong(Me.hwnd, GWL_EXSTYLE) '获得窗体的扩展式样
NewStyle = WinStyle + WS_EX_LAYERED '窗体新式样
SetWindowLong Me.hwnd, GWL_EXSTYLE, NewStyle '付值给窗体新的式样
SetLayeredWindowAttributes Me.hwnd, RGB(255, 0, 0), 200, LWA_COLORKEY_ALPHA '异形+半透明

' SetLayeredWindowAttributes Me.hwnd, 0, 128, LWA_ALPHA '半透明
' SetLayeredWindowAttributes Me.hwnd, RGB(255, 0, 0), 0, LWA_COLORKEY '异形
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Call ReleaseCapture
Call SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub

1,485

社区成员

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

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