Option Explicit '函数声明
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
'GetPixel
'VB声明
'Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
'说明
'在指定的设备场景中取得一个像素的RGB值
'返回值Long,指定点的RGB颜色。如指定的点位于设备场景的剪切区之外,则返回CLR_INVALID
'参数 类型及说明
'hdc Long,一个设备场景的句柄
'x,y Long,逻辑坐标中要检查的点
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
'SetWindowRgn
'VB声明
'Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
'说明
'这是那些很难有人注意到的对编程者来说是个巨大的宝藏的隐含的API函数中的一个?本函数允许您改变窗口的区域?
'通常所有窗口都是矩形的——窗口一旦存在就含有一个矩形区域。本函数允许您放弃该区域。这意味着您可以创建圆的、星形的窗口,也可以将它分为两个或许多部分——实际上可以是任何形状
'返回值Long,执行成功为非零值,失败为0
'参数表
'参数 类型及说明
'hWnd Long,将设置其区域的窗口
'hRgn Long,将设置的区域的句柄,一旦设置了该区域,就不能使用或修改该区域句柄,也不要删除它
'bRedraw Boolean,若为TRUE,则立即重画窗口
'注解
'为区域指定的所有坐标都以窗口坐标(不是客户坐标)表示,它们以整个窗口(包括标题栏和边框)的左上角为起点
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
'CreateRectRgn
'VB声明
'Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
'说明
'创建一个由点X1,Y1和X2,Y2描述的矩形区域
'返回值Long,执行成功为区域句柄,失败则为零
'参数表
'参数 类型及说明
'X1,Y1 Long,矩形左上角X,Y坐标
'X2,Y2 Long,矩形右下角X,Y坐标
'注解
'不用时一定要用DeleteObject函数删除该区域
'这个矩形的下边和右边不包含在区域之内
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
'CombineRgn
'VB声明
'Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
'说明
'将两个区域组合为一个新区域
'返回值Long,下列常数之一:
'COMPLEXREGION: 区域有互相交叠的边界
'SIMPLEREGION: 区域边界没有互相交叠
'NULLREGION: 区域为空
'ERRORAPI: 不能创建组合区域
'参数表
'参数 类型及说明
'hDestRgn Long,包含组合结果的区域句柄
'hSrcRgn1 Long,源区域1
'hSrcRgn2 Long,源区域2
'nCombineMode Long,组合两区域的方法。可设为下述常数
'RGN_AND hDestRgn被设置为两个源区域的交集
'RGN_COPY hDestRgn被设置为hSrcRgn1的拷贝
'RGN_DIFF hDestRgn被设置为hSrcRgn1中与hSrcRgn2不相交的部分
'RGN_OR hDestRgn被设置为两个区域的并集
'RGN_XOR hDestRgn被设置为除两个源区域OR之外的部分
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'DeleteObject
'VB声明
'Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'说明
'用这个函数删除GDI对象,比如画笔、刷子、字体、位图、区域以及调色板等等。对象使用的所有系统资源都会被释放
'返回值Long,非零表示成功,零表示失败
'参数表
'参数 类型及说明
'hObject Long,一个GDI对象的句柄
'注解
'不要删除一个已选入设备场景的画笔、刷子或位图。如删除以位图为基础的阴影(图案)刷子,位图不会由这个函数删除——只有刷子被删掉
Const RGN_OR = 2
Dim I As Integer, j, myint, linex As Integer
Dim Fullr, myColor, crn As Long
Dim Region, PicWidth, PicHeight As Long
Dim mystart, mybool As Boolean
Private Sub Form_Load()
Dim hdc As Long
Me.Width = Picture1.Width '设置窗体宽度等于图形宽度
Me.Height = Picture1.Height '设置窗体宽度等于图形宽度
Picture1.ScaleMode = vbPixels '设置Picture1度量单位为像素
Picture1.AutoRedraw = True '设置Picture1自动重绘有效
Picture1.AutoSize = True '设置Picture1自动调整大小
Picture1.BorderStyle = vbBSNone '设置Picture1的边框样式
Me.BorderStyle = vbBSNone '设置窗体的边框样式
hdc = Picture1.hdc
mystart = True
mybool = False
I = 0
j = 0
PicWidth = Picture1.ScaleWidth
PicHeight = Picture1.ScaleHeight
linex = 0
myColor = GetPixel(hdc, 0, 0) '获取picture1指定像素的rgb值
For j = 0 To PicHeight - 1
For I = 0 To PicWidth - 1
If GetPixel(hdc, I, j) = myColor Or I = PicWidth Then '透明像素
If mybool Then
mybool = False
crn = CreateRectRgn(linex, j, I, j - 1) '创建矩形区域
If mystart Then
Fullr = crn
mystart = False
Else
CombineRgn Fullr, Fullr, crn, RGN_OR '合并区域
DeleteObject CreateRectRgn(linex, j, I, j - 1) '删除透明区域
End If
End If
Else '非透明像素
If Not mybool Then
mybool = True
linex = I
End If
End If
Next
Next
Region = Fullr
SetWindowRgn Me.hWnd, Region, True '设置窗体区域
myint = 0
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
MsgBox "拖动还没做好!你做一下,试试看!"
Else
MsgBox "帮助还没做好!你做一下,试试看!"
End If
End Sub
Private Sub Timer1_Timer() '形成动画
Dim hdc As Long
myint = myint + 1
If myint = 1 Then Set Picture1.Picture = LoadPicture(App.Path & "\sz3.bmp")
If myint = 2 Then Set Picture1.Picture = LoadPicture(App.Path & "\sz4.bmp")
If myint = 3 Then Set Picture1.Picture = LoadPicture(App.Path & "\sz5.bmp")
If myint = 4 Then Set Picture1.Picture = LoadPicture(App.Path & "\sz6.bmp")
If myint = 5 Then myint = 0
hdc = Picture1.hdc
mystart = True
mybool = False
I = 0
j = 0
Me.Width = Picture1.Width
Me.Height = Picture1.Height
PicWidth = Picture1.ScaleWidth
PicHeight = Picture1.ScaleHeight
linex = 0
myColor = GetPixel(hdc, 0, 0) '获取picture1指定像素的rgb值
For j = 0 To PicHeight - 1
For I = 0 To PicWidth - 1
If GetPixel(hdc, I, j) = myColor Or I = PicWidth Then '透明像素
If mybool Then
mybool = False
crn = CreateRectRgn(linex, j, I, j - 1) '创建矩形区域
If mystart Then
Fullr = crn
mystart = False
Else
CombineRgn Fullr, Fullr, crn, RGN_OR '合并区域
DeleteObject CreateRectRgn(linex, j, I, j - 1) '删除透明区域
End If
End If
Else '非透明像素
If Not mybool Then
mybool = True
linex = I
End If
End If
Next
Next
Region = Fullr
SetWindowRgn Me.hWnd, Region, True '设置窗体区域
End Sub
'Private Sub Picture1_Click()
'End
'End Sub
'API 函数申明
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 Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long,ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long,ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
'定义变量
Dim x1, x2, y1, y2, cx, cy, dx, dy, i, num
'结束程序
Private Sub Command1_Click()
End
End Sub
'移动窗口
Private Sub Command2_Click()
i = SendMessage(Form1.hwnd, &H112, &HF010, 0&)
End Sub
'鼠标拖动窗口
Private Sub form_MouseMove(Button As Integer, Shift As Integer,X As Single, Y As Single)
Dim mx, myleftDown = (Button And vbLeftButton) > 0
rightDown = (Button And vbRightButton) > 0
If (leftDown Or rightDown) Then
mx = X - dx
my = Y - dy
Form1.Left = Form1.Left + mx
Form1.Top = Form1.Top + my
Form1.CurrentX = 10
Form1.CurrentY = 10
End If
End Sub
' 记录当前鼠标位置
Private Sub Form_MouseDown(Button As Integer, Shift As Integer,X As Single, Y As Single)
dx = X
dy = Y
End Sub
'实时显示时间并判断当前窗口的状态
Private Sub Timer1_Timer()
Label1.Caption = Now
If Form1.WindowState = 1 Then
SetWindowRgn Form1.hwnd, CreateRectRgn(0, 0, x2, y2), True
Form1.Caption = Now
Else
SetWindowRgn Form1.hwnd, CreateEllipticRgn(x1, y1, x2, y2), True
End If
End Sub