【叶帆开源区】任意透明窗体－－运用API实现特异窗体

[叶帆]

特异窗体是制作一些娱乐小程序所应该掌握的基本功，现把源码公开供大家参考，希望大家也贴出自己的解决方案

程序界面：http://www.bjjr.com.cn/yefan/pic/tform.jpg
源码下载：http://http://blog.csdn.net/yefanqiu 【叶帆源码】－任意透明窗体

部分源码：－－－－－－－－－－－－－－－－－－－－－－－
'*************************************************************************
'**模 块 名：mdlBase
'**说 明：YFHome 版权所有2004 - 2005(C)
'**创 建 人：叶帆
'**日 期：2004-09-19
'**修 改 人：
'**日 期：
'**描 述：透明窗体
'**版 本：V1.0.0
'*************************************************************************
Option Explicit

'*************************************************************************
'**窗体最前有关函数
'*************************************************************************
Public 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)
Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE

'*************************************************************************
'**移动窗体有关函数
'*************************************************************************
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

'*************************************************************************
'**透明窗体有关函数
'*************************************************************************
Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public Const RGN_OR = 2

Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'*************************************************************************
'** 背景图图片格式说明 （前景图片可以为真彩色）
'**-----------------------------------------------------------------------
'**1、图片必须是8位格式的BMP图片
'**2、图片颜色最好为双色
'**3、左上角一点颜色为默认透明色
'*************************************************************************
'*************************************************************************
'**函 数 名：SetAutoRgn
'**输 入：hForm(Form) - 窗体
'** ：Optional transColor(Byte = vbNull) - 欲透明的色
'**输 出：无
'**功能描述：透明窗体
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2004-09-19
'**修 改 人：
'**日 期：
'**版 本：V1.0.0
'*************************************************************************
Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
Dim X As Long, Y As Long
Dim Rgn1 As Long, Rgn2 As Long
Dim SPos As Long, EPos As Long
Dim bm As BITMAP
Dim hbm As Long
Dim Wid As Long, Hgt As Long
Dim bmByte() As Byte

'获取窗体背景图片尺寸
hbm = hForm.Picture
GetObjectAPI hbm, Len(bm), bm
Wid = bm.bmWidth + 1
Hgt = bm.bmHeight

ReDim bmByte(1 To Wid, 1 To Hgt)
GetBitmapBits hForm.Picture, Wid * Hgt, bmByte(1, 1) '获取图像数组
If transColor = vbNull Then transColor = bmByte(1, 1)
Rgn1 = CreateRectRgn(0, 0, 0, 0)
For Y = 1 To Hgt '逐行扫描
X = 0
Do
X = X + 1
While (bmByte(X, Y) = transColor) And (X < Wid)
X = X + 1 '跳过透明色的点
Wend
SPos = X
While (bmByte(X, Y) <> transColor) And (X < Wid)
X = X + 1 '跳过不是透明色的点
Wend
EPos = X - 1
'这一段是合并区域
If SPos <= EPos Then
Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y)
CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
DeleteObject Rgn2
End If
Loop Until X >= Wid
Next Y
SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
DeleteObject Rgn1
End Sub

'*************************************************************************
'**函 数 名：setFormTop
'**输 入：hwnd(Long) - 窗体句柄
'**输 出：无
'**功能描述：令指定窗体最前
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2004-09-19
'**修 改 人：
'**日 期：
'**版 本：V1.0.0
'*************************************************************************
Public Sub setFormTop(hwnd As Long)
SetWindowPos hwnd, -1, 0, 0, 0, 0, FLAGS
End Sub

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
【叶帆开源区】其它链接
XP界面窗体制作（可放缩、可缩小到托盘）
http://community.csdn.net/Expert/topic/3387/3387552.xml?temp=.416424
有意思的老人源码
http://community.csdn.net/Expert/topic/3376/3376547.xml?temp=.1939661
VB源码之友
http://community.csdn.net/Expert/topic/3365/3365079.xml?temp=7.926577E-02
定制公用对话框（如photoshop的文件打开对话框）
http://community.csdn.net/Expert/topic/3385/3385386.xml?temp=.2206842
绝对经典的扫雷源码(仿微软扫雷界面）－－可以作弊呢！！！
http://community.csdn.net/Expert/topic/3380/3380429.xml?temp=.3048517
MSComm串口通信示例
http://community.csdn.net/Expert/topic/3387/3387736.xml?temp=.2366754

[zjcxc]

mark

[netcoder]

好东东

[laviewpbt]

//这则代码大概是我2000年前写的
wxj_lake(蔚蓝的风)活了二千多年了啊，应该成仙了吧。呵呵

[laviewpbt]

to://pigpag(噼里啪啦)
看看这里有没有你想要的东西
http://www.aivisoft.net/zyl910/index.asp

[wxj_lake]

to qiqi5521: 边缘追踪只适合复杂度较低的连续几何形体。如果是一幅前景对象众多，每个像素点都可能不连续的照片，那么还不如扫描全部像素点。而且经过试验，在内存中软件扫描全屏位图的时间也在0.5秒之内（1024*758, 500MHz CPU）。 几年过去了，现在的CPU应该更快了，因此效率的问题不大。

但是这绝对不是最好的方式。我才疏学浅，而且时过境迁，这辈子也无能力在程序算法上有所精进了。这都不重要，相信自有图形学的高手在，请教他们吧。

[vbman2003]

值得好好学习学习

[qiqi5521]

///边缘追踪只适合复杂度较低的连续几何形体

不错，的确是这样。用边缘追踪有两个要求，一是：必须是连续几何体，如果是分离体，肯定只能识别一个。二是：必须是实心的形体。

[叶帆]

to wxj_lake(蔚蓝的风)

不好意思，这段代码确实是整理的，有可能也是从转贴的转贴所获得的源码，所以丢失了原作者信息

谢谢 wxj_lake(蔚蓝的风)的开源精神，图形技术我不算擅长，以zyl910等为首的图像技术使我受益良多，这里不敢夺爱

恢复这个源码的出处：蔚蓝的风 （可否提供你的较详细信息）

[qiqi5521]

如果我没看错的话，这个代码是遍历了所有像素才最终建立了区域吧？
这方法的效率应该是比较低的。其实可以做边缘追踪，这样会更快一些。
一般的边缘追踪是左手法，不过现在一般不用了，在很早的《电维》上有一篇
介绍基于知识的改良左手法的边缘追踪的文章，很不错的。

[qiqi5521]

不过这段代码确实不错，学到很多东西，值得收藏

[wxylvmnn]

我是看人气进来的。。。。

这里好热闹。。。。

[pigpag]

//to://pigpag(噼里啪啦)
看看这里有没有你想要的东西
http://www.aivisoft.net/zyl910/index.asp

谢谢!!应该有吧，我差点儿忘了 :)

[pigpag]

……没有 :'(

[无影追风]

如果能用PNG图像做透明窗体才好

[DemonLoveLizzy]

思路一样，但做法太麻烦了。
应该用PICTUREBOX做图片载体，它有HDC，就可以直接在PICBOX上创建区域，然后直接在FORM上切割窗体。只要1幅图。

窗体代码。窗体边框=0
Private Sub Form_Load()

Dim WindowRegion As Long
Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture1.BorderStyle = vbBSNone
Me.BorderStyle = vbBSNone
Me.Width = Picture1.Width
Me.Height = Picture1.Height
WindowRegion = MakeRegion(Picture1)
SetWindowRgn Me.hwnd, WindowRegion, True

End Sub

Private Sub Picture1_DblClick()
End
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

模块代码
Option Explicit

Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Const RGN_OR = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2


Public Function MakeRegion(picSkin As PictureBox) As Long

Dim x As Long, y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim TransparentColor As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean
Dim hDC As Long
Dim PicWidth As Long
Dim PicHeight As Long

hDC = picSkin.hDC
PicWidth = picSkin.ScaleWidth
PicHeight = picSkin.ScaleHeight

InFirstRegion = True: InLine = False
x = y = StartLineX = 0

TransparentColor = GetPixel(hDC, 0, 0)

For y = 0 To PicHeight - 1
For x = 0 To PicWidth - 1

If GetPixel(hDC, x, y) = TransparentColor Or x = PicWidth Then

If InLine Then
InLine = False
LineRegion = CreateRectRgn(StartLineX, y, x, y + 1)

If InFirstRegion Then
FullRegion = LineRegion
InFirstRegion = False
Else
CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR

DeleteObject LineRegion
End If
End If
Else

If Not InLine Then
InLine = True
StartLineX = x
End If
End If
Next
Next

MakeRegion = FullRegion
End Function

我在2001年写的。呵呵

[ljhdi]

支持一下

[wxj_lake]

to DemonLoveLizzy： 这个题目中最关键的速度。你的代码要花多少时间来切割呢？据我的印象（太久了，有可能记错），GetPixel函数的速度是很慢的，如果你看一下platform sdk中的函数原型，就会了解。图片框的HDC并不是位图的HDC，两次寻找后还要根据坐标定位，这速度可想而知。

现在这段代码的弱点是GetBitmapBits只能处理设备相关位图，如果能处理DIB设备无关位图则更高。看一下我的后来的更新代码 http://www.archtide.com/bib/detail.asp?id=403，代码更复杂了，幸而借用了VBacceleration的一个模块。那个时候就始终觉得国外的研究水平很高，不是吹出来的。

[Amoon]

误导,明明是不规则窗体,说成任意透明.

[Amoon]

还有,做蒙板的时候整个位图扫描在图大的时候很费时间的。效率不如往一个单色的位图里面复制.

[bacaihong]

太多没时间看，先Mark一下