这么简单啊,不知道是不是真的啊,不过,还是告诉你一下把,看着给分啊:Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As LongPrivate Declare Function GetClientRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As LongPrivate Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As LongPrivate Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function ScreenToClient Lib "user32" (ByVal hWnd As _
Long, lpPoint As POINTAPI) As LongPrivate Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongConst RGN_AND = 1
Const RGN_COPY = 5
Const RGN_DIFF = 4
Const RGN_OR = 2
Const RGN_XOR = 3Private 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 SubPublic 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 SubPrivate Sub Form_Click()
MakeTransparent Me
End Sub
Long, lpRECT As RECT) As LongPrivate Declare Function GetClientRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As LongPrivate Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As LongPrivate Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function ScreenToClient Lib "user32" (ByVal hWnd As _
Long, lpPoint As POINTAPI) As LongPrivate Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongConst RGN_AND = 1
Const RGN_COPY = 5
Const RGN_DIFF = 4
Const RGN_OR = 2
Const RGN_XOR = 3Private 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 SubPublic 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 SubPrivate Sub Form_Click()
MakeTransparent Me
End Sub
解决方案 »
- 本人正在练习做网页游戏的外挂,无法解决窗口最小化的问题,请高手们帮忙。
- 求一关闭ADSL,重启ADSL的模块.
- Winsock控件点对点通讯,局域网正常,广域网连接(求教)
- 关于kodak image控件问题
- VB中有什么好的对象存放数据比较方便?最好类似于recordset.
- 一個奇怪的錯誤,有誰知道嗎?(重分相謝)
- vb6.0 调用dll 请高手帮忙 如何区姓名,余额 和读卡 谢谢 只要写出调用示例就行 另加200大米,测试通过绝不失言
- 打印边界的设定问题?
- 请教如何自动更新程序?
- 一个简单又复杂的问题,请各位老大帮帮忙...
- 高手帮忙!
- 请问大家都是如何用VB实现报表打印功能的,都用什么方法?
Private Declare Sub ReleaseCapture Lib "User32" ()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 Declare Function SetLayeredWindowAttributes Lib "User32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongConst WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
Private Sub Form_Load()
DarkMe
With Label1
.WordWrap = True
.Caption = " Drag Here "
End With
With Label2
.Caption = "X"
.Height = Label1.Height
.Top = Label1.Top
End With
End SubPrivate Sub Image1_Click()End SubPrivate Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Call ReleaseCapture
SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End SubPublic Function DarkMe()
Dim rtn As Long
rtn = GetWindowLong(hWnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hWnd, 0, 200, LWA_ALPHA
'上面的200是透明度,0就完全透明,255就完全不透明
End Function'在窗口上加一个image1,一个label1,一个label2 ,记住颜色不要设定成白色
'记住给分啊,不然下次不帮啦。
在label2 的click 事件上加上关闭的代码(随你便加不加都行啦)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const LWA_ALPHA = &H2&
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As IntegerPrivate Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_ACTIVATEAPP = &H1C
Private Const GWL_WNDPROC = -4
Public lpPrevWndProc As Long
Public gHW As Long
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 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 Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Integer
Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPrivate Type POINTAPI
x As Long
Y As Long
End TypePrivate 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 LongPrivate Const SWP_NOMOVE = &H2, SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1, HWND_NOTOPMOST = -2
Sub SetTopmostWindow(ByVal hwnd As Long, Optional topmost As Boolean = True)
Const HWND_NOTOPMOST = -2
Const HWND_TOPMOST = -1
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
SetWindowPos hwnd, IIf(topmost, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, _
SWP_NOMOVE + SWP_NOSIZE
End Sub
Private Sub Check1_Click()
If Check1.Value = vbChecked Then
SetTopmostWindow Me.hwnd, True
Else
SetTopmostWindow Me.hwnd, False
End If
End Sub
Private Sub Command1_Click()
If List1.ListIndex = -1 Then
MsgBox "Select a window from the above list", vbExclamation, App.Title
Exit Sub
End If
Dim NormalWindowStyle As Long
Dim sSplit() As String
Dim HWD As Long
sSplit = Split(List1.Text, "|")
HWD = CLng(sSplit(1))
NormalWindowStyle = GetWindowLong(HWD, GWL_EXSTYLE)
SetWindowLong HWD, GWL_EXSTYLE, NormalWindowStyle Or WS_EX_LAYERED SetLayeredWindowAttributes HWD, 0, HS, LWA_ALPHA
End SubPrivate Sub Command2_Click()
Unload Me
End
End SubPrivate Sub Command3_Click()
List1.Clear
End SubPrivate Sub Form_Load()
App.Title = "Set Window Transparency"
Me.Caption = App.Title
Check1_Click
End SubPrivate Sub Picture1_Click()
ShellExecute 0, vbNullString, "mailto:[email protected]", vbNullString, vbNullString, vbNormalFocusEnd SubPrivate Sub Timer1_Timer()
Dim info As String
info = GetInformation(Me.hwnd, List1.hwnd, Command1.hwnd, Command2.hwnd, Command3.hwnd, Check1.hwnd, HS.hwnd)
If info > "" And Left(info, 1) <> "|" Then
If Not isWindowInList(info) Then
List1.AddItem info
End If
End If
End Sub
Function isWindowInList(ByVal sIN As String) As Boolean
Dim x As Integer
isWindowInList = False
For x = 0 To List1.ListCount - 1
If sIN = List1.List(x) Then
isWindowInList = True
End If
Next x
End Function
Private Function GetInformation(ParamArray HwndExcluded() As Variant) As String
On Error Resume NextDim CursorPos As POINTAPI
Dim szText As String * 100
Dim HoldText As String
Dim HwndNow As Long, hInst As Long
Dim Rct As RECT, R As Long
Dim I
Static HwndPrev As LongConst GWW_HINSTANCE = (-6), GWW_ID = (-12), GWL_STYLE = (-16)GetCursorPos CursorPosHwndNow = WindowFromPoint(CursorPos.x, CursorPos.Y)For I = LBound(HwndExcluded) To UBound(HwndExcluded)
If HwndNow = CLng(HwndExcluded(I)) Then Exit Function
Next I
GetInformation = ""
If HwndNow <> HwndPrev Then
HwndPrev = HwndNow
R = GetWindowText(HwndNow, szText, 100)
GetInformation = Left(szText, R) & "|"
GetInformation = GetInformation & HoldText & CStr(HwndNow) & "|"
GetInformation = GetInformation & GetWindowWord(HwndNow, GWW_HINSTANCE)
End If
End Function
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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 Form_Load() Dim rtn As Long
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, 0, LWA_ALPHAEnd Sub
SetLayeredWindowAttributes只有在win2000以上才有
kiti(小胡桃) 的(第一个程序)是将窗体完全透明,而不是半透明!
你们自己试一下吧!
SetLayeredWindowAttributes只有在win2000以后版本里才存在。而且,如果实现全部透明,可以按照kiti(小胡桃)的办法再进行一步操作:扫描目标图形,只保留需要保留的Rgn,其他的都剪掉。
我身边没有代码,谁有兴趣要这500分,
贴一个通过扫描目标图片实现透明的例子就可以了。
在Timer控件中判断窗体位置,如果改变则再画一次背景用那篇帖子讲的方法
可以实现背景是静态的半透明
动态的无法实现其实微软都没有把Win98下背景是动态半透明编出来
大家都知道,拖动文件的时候,文件的图标是半透明的
如果你把桌面背景设为一动态Gif,再拖动桌面的图标,你会发现桌面背景的那幅动态Gif停止运动了
能不能把你的代码在改一下啊,我想实现可以加入容器控件和不见控件的功能啊,因为我水平不高,不会自己改,呵呵,请再帮帮忙啊,最好代码能有详细的注释说明就最好了, 在次感谢
改完后我将给分,给你500分,给kiti 100分,呵呵,不会失言的!!!
good_sun(八锖):
能不能把你的代码在改一下啊,我想实现可以加入容器控件和不见控件的功能啊,因为我水平不高,不会自己改,呵呵,请再帮帮忙啊,最好代码能有详细的注释说明就最好了, 在次感谢
改完后我将给分,给你500分,给kiti 100分,呵呵,不会失言的!!!
====================================================================
半透明的控件
WinXP都不支持
更别说可以作为容器的控件如果你非要作出那样的效果的话
先找几本图像处理、游戏编程的书看看具体做法是:
仿照编游戏界面的方法
在一个PictureBox中绘制“控件”(不是真正的控件,是你画出来的)
并根据鼠标键盘消息处理控件图像(如你的按键按下)为了好调用,可以把那些“控件”放在类模块中
需要是再生成
Option ExplicitPublic Const RGN_AND = 1
Public Const RGN_COPY = 5
Public Const RGN_DIFF = 4
Public Const RGN_OR = 2
Public Const RGN_XOR = 3Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'区域的设置与获取
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'合并区域
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPublic Sub GetFormRect(ByVal frm As Form, ByRef rctframe As RECT, ByRef rctclient As RECT)
'获得窗口矩形区域
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 = 0End Sub'form1
Option ExplicitPrivate Sub Command1_Click()
Dim X As Long
Dim Y As Long
Dim r1 As RECT
Dim r2 As RECT
Dim lngR1 As Long
Dim lngRTemp As LongGetFormRect Me, r1, r2
lngR1 = CreateRectRgn(r1.Left, r1.Top, r1.Right, r1.Bottom)For X = 0 To Abs(r2.Right - r2.Left) Step 3
For Y = 0 To Abs(r2.Bottom - r2.Top) Step 3
lngRTemp = CreateRectRgn(X + Abs(r2.Left), Y + Abs(r2.Top), X + Abs(r2.Left) + 1, Y + Abs(r2.Top) + 1)
CombineRgn lngR1, lngR1, lngRTemp, RGN_XOR
Next Y
Next XSetWindowRgn Me.hwnd, lngR1, True
End Sub
'点完了按钮要等一会噢,效果不算好,不过呢,真正的半透明也不好作~
'效果挺有趣的
现在,www.myvc.net将为大家提供一个资源下载的空间!第一批将提供<三层结构源代码>
<开发文档模版>两项。
需要者可去以下网址留下email
http://www.myvc.net/dispbbs.asp?boardID=16&RootID=658&ID=658&page=1
我们也提供资源上传的空间,如果你愿意和大家分享你的资源,你可以和www.myvc.net联系