| 发表于：2007-04-04 16:51:524楼 得分:50 |
类模块：
option explicit
private type bitmapfileheader
bftype as integer
bfsize as long
bfreserved1 as integer
bfreserved2 as integer
bfoffbits as long
end type
private type bitmapinfoheader
bisize as long
biwidth as long
biheight as long
biplanes as integer
bibitcount as integer
bicompression as long
bisizeimage as long
bixpelspermeter as long
biypelspermeter as long
biclrused as long
biclrimportant as long
end type
private 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
private const dib_rgb_colors as long = 0
private const obj_bitmap as long = 7
private const srccopy as long = &hcc0020
private const coloroncolor as long = 3
private const cf_bitmap as long = 2
private declare function createdibsection lib "gdi32 " （byval hdc as long, lpbitsinfo as bitmapinfoheader, byval wusage as long, lpbits as long, byval handle as long, byval dw 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 getobject lib "gdi32 " alias "getobjecta " （byval hobject as long, byval ncount as long, lpobject as any) as long
private declare function getobjecttype lib "gdi32 " （byval hgdiobj 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 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 varptrarray lib "msvbvm50 " alias "varptr " （ptr（) as any) as long
private declare sub copymemory lib "kernel32 " alias "rtlmovememory " （lpdst as any, lpsrc as any, byval bytelength as long)
private mbmpinfoheader as bitmapinfoheader
private mhdc as long
private mhdib as long
private mholddib as long
private mptr as long
private mwidthbytes as long
public property get hdc（) as long
hdc = mhdc
end property
public property get datasize（) as long
datasize = mbmpinfoheader.bisizeimage
end property
public property get width（) as long
width = mbmpinfoheader.biwidth
end property
public property get height（) as long
height = mbmpinfoheader.biheight
end property
public property get colorbit（) as long
colorbit = mbmpinfoheader.bibitcount
end property
public property get dataptr（) as long
dataptr = mptr
end property
public property get widthbytes（) as long
widthbytes = mwidthbytes
end property
public function create（byval newwidth as long, byval newheight as long, optional byval bits as long = 32) as boolean
destroy '销毁以前的dib
mhdc = createcompatibledc（0) '创建dib设备场景
if （mhdc <> 0) then '创建成功
with mbmpinfoheader '位图信息头
.bisize = len（mbmpinfoheader)
.biplanes = 1
.bibitcount = bits
.biwidth = newwidth
.biheight = newheight
select case bits
case 1
mwidthbytes = （（（.biwidth + 7) \ 8 + 3) and &hfffffffc)
case 4
mwidthbytes = （（（.biwidth + 1) \ 2 + 3) and &hfffffffc)
case 8
mwidthbytes = （（.biwidth + 3) and &hfffffffc)
case 16
mwidthbytes = （（.biwidth * 2 + 3) and &hfffffffc)
case 24
mwidthbytes = （（.biwidth * 3 + 3) and &hfffffffc)
case 32
mwidthbytes = .biwidth * 4
case else
exit function
end select
.bisizeimage = mwidthbytes * .biheight
end with
mhdib = createdibsection（mhdc, mbmpinfoheader, dib_rgb_colors, mptr, 0, 0) '创建dib
if （mhdib <> 0) then
mholddib = selectobject（mhdc, mhdib) '选入设备场景
else
destroy '如果dib创建失败，需销毁dib设备场景
end if
end if
create = （mhdib <> 0)
end function
public sub destroy（)
if mhdc <> 0 then
if mhdib <> 0 then
selectobject mhdc, mholddib
deleteobject mhdib
end if
deleteobject mhdc
mbmpinfoheader.bibitcount = 0
mbmpinfoheader.biwidth = 0
mbmpinfoheader.biheight = 0
mbmpinfoheader.bisizeimage = 0
end if
mhdc = 0: mhdib = 0: mholddib = 0: mptr = 0
end sub
public function createfromstdpicture（byval picture as stdpicture, optional bits as byte = 32, optional byval dwrop as rasteropconstants = vbsrccopy) as boolean
dim bmp as bitmap
if getobject（picture.handle, len（bmp), bmp) = 0 then exit function
if （getobjecttype（picture) = obj_bitmap) then
if bits = 0 then bits = bmp.bmbitspixel
create bmp.bmwidth, bmp.bmheight, bits
if mhdib <> 0 then '说明上面的创建函数成功了
dim sourcedc as long, olddib as long
sourcedc = createcompatibledc（mhdc)
olddib = selectobject（sourcedc, picture.handle)
bitblt mhdc, 0, 0, bmp.bmwidth, bmp.bmheight, sourcedc, 0, 0, dwrop
selectobject sourcedc, olddib
deletedc sourcedc
createfromstdpicture = true
end if
end if
end function
public function output（byval outdc as long, optional byval x as long = 0, optional byval y as long = 0, optional byval width as long, optional byval height as long, optional byval xsrc as long = 0, optional byval ysrc as long = 0, optional byval dwrop as rasteropconstants = vbsrccopy) as boolean
if mhdib = 0 then exit function
if width = 0 then width = mbmpinfoheader.biwidth
if height = 0 then height = mbmpinfoheader.biheight
output = bitblt（outdc, x, y, width, height, mhdc, xsrc, ysrc, dwrop)
end function
| | |
|
