WindowsNuclear
Oct 12th, 2002, 04:49 AM
'This methode Can use a backgroud picture, to form the from
'as the picture's figure.
'Just assigned a color from all colors of the picture as the "transparence" color,just as 'gif dose.
'Declaration
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Const RGN_OR = 2
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
Dim bmbyte() As Byte
Public Sub SetAutoRgn(hfrom 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
'get the size of the backgroud picture
hbm = hform.Picture
GetObject hbm, Len(bm), bm
wid = bm.bmWidth
hgt = bm.bmHeight
hform.Height = hgt * Screen.TwipsPerPixelY
hform.Width = wid * Screen.TwipsPerPixelX
ReDim bmbyte(1 To wid, 1 To hgt)
'get arrays of picture's pelses
GetBitmapBits hbm, 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
' The code's author is the host of WWW.ARCHTIDE.COM, but this
'function cause error in my
'Program.Can anybody know what's wrong with it?THS
'as the picture's figure.
'Just assigned a color from all colors of the picture as the "transparence" color,just as 'gif dose.
'Declaration
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Const RGN_OR = 2
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
Dim bmbyte() As Byte
Public Sub SetAutoRgn(hfrom 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
'get the size of the backgroud picture
hbm = hform.Picture
GetObject hbm, Len(bm), bm
wid = bm.bmWidth
hgt = bm.bmHeight
hform.Height = hgt * Screen.TwipsPerPixelY
hform.Width = wid * Screen.TwipsPerPixelX
ReDim bmbyte(1 To wid, 1 To hgt)
'get arrays of picture's pelses
GetBitmapBits hbm, 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
' The code's author is the host of WWW.ARCHTIDE.COM, but this
'function cause error in my
'Program.Can anybody know what's wrong with it?THS