您的位置：程序门 -> vb -> 多媒体

图像拷贝代码

[收藏此页] [打印本页]选择字色：背景色：字体：[大][中][小]

图像拷贝代码

发表于：2007-11-19 22:48:14 楼主

下面是我从网上找到的一段代码,大家帮忙看看为何不能将picture1 中的图像考到 picture2 中去，而只能得到屏幕左上角的图像。form 中有picture1,picture2 and command1 三个控件。

option explicit

'下面解释一下在过程中到的全局变量和数据结构，以及api的定义。
'
'api定义:
'删除一个dc
private declare function deletedc lib "gdi32" （byval hdc as long) as long
'删除一个对象
private declare function deleteobject lib "gdi32" （byval hobject as long) as long
'选择当前对象
private declare function getcurrentobject lib "gdi32" （byval hdc as long, byval uobjecttype as long) as long
'获取dib
private declare function getdibits lib "gdi32" （byval ahdc as long, byval hbitmap as long, byval nstartscan as long, byval nnumscans as long, lpbits as any, lpbi as bitmapinfo, byval wusage as long) as long
'获取系统时间
private declare function timegettime lib "winmm.dll" （) as long

'数据结构定义:
private type bitmapinfoheader '文件信息头——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 rgbquad
rgbblue as byte
rgbgreen as byte
rgbred as byte
'rgbreserved as byte
end type

private type bitmapinfo
bmiheader as bitmapinfoheader
bmicolors as rgbquad
end type
'这三个数据结构都是在dib中不可缺少的。我们不必深究，只是按照顺序复制粘贴直接使用就是了。
'
'过程中用到的全局变量:
private const bits as long = 32 '颜色深度，这里把所有图像都按照32位来处理
public done as boolean '用于标记一个过程是否结束
public timeget as long '用于记录输入过程处理所花费的时间
public timeput as long '用于记录输出过程处理所花费的时间
dim colval（) as byte '用于存放从dib输入的像素值
dim colout（) as byte '用于存放向dib输出的像素值
dim inputhei as long '用于记录输入图像的高度
dim inputwid as long '用于记录输入图像的宽度
dim bi24bitinfo as bitmapinfo '定义bmp信息

private declare sub copymemory lib "kernel32" alias "rtlmovememory" （pdest as any, psrc as any, byval bytelen as long)
private declare function setdibitstodevice lib "gdi32" （byval hdc as long, byval x as long, byval y as long, byval dx as long, byval dy as long, byval srcx as long, byval srcy as long, byval scan as long, byval numscans as long, bits as any, bitsinfo as bitmapinfo, byval wusage as long) as long

public sub copydata（byval w as long, byval h as long)
dim length as long
dim i as long
dim l as long
i = bits \ 8
l = i - 1
length = （w + 1&) * （h + 1&) * i
redim colout（l, w, h)
copymemory colout（0, 0, 0), colval（0, 0, 0), length
end sub

public sub dibget（byval idsource as long, xbegin as long, byval ybegin as long, byval xend as long, byval yend as long)
dim ibitmap as long
dim idc as long
dim i as long
dim w as long
dim h as long

on error goto errline
done = false
timeget = timegettime
inputwid = xend - xbegin
inputhei = yend - ybegin
w = inputwid + 1
h = inputhei + 1

i = （bits \ 8) - 1
redim colval（i, inputwid, inputhei)
with bi24bitinfo.bmiheader
.bibitcount = bits
.bicompression = 0&
.biplanes = 1
.bisize = len（bi24bitinfo.bmiheader)
.biwidth = w
.biheight = h
end with

ibitmap = getcurrentobject（idsource, 7&)
getdibits idsource, ibitmap, 0&, h, colval（0, 0, 0), bi24bitinfo, 0&

deleteobject ibitmap
done = true
timeget = timegettime - timeget
exit sub
errline:
msgbox "错误号：" & err.number & "：" & err.description
end sub
'在这个过程中所用到的只是一些参数的设定和api的调用，不涉及算法。
'
'过程二: 图像输出的过程:
public sub dibput（byval iddestination as long)
dim w as long
dim h as long

dim linebytes

on error goto errline
done = false
timeput = timegettime
w = inputwid + 1
h = inputhei + 1

with bi24bitinfo.bmiheader
.biwidth = w
.biheight = h
linebytes = （（w * bits + 31) and &hffffffe0) \ 8
.bisizeimage = linebytes * h
end with
setdibitstodevice iddestination, 0, 0, w, h, 0, 0, 0, h, colout（0, 0, 0), bi24bitinfo, 0

done = true
timeput = timegettime - timeput
exit sub
errline:
msgbox err.description
end sub

private sub command1_click（)
with picture1
.scalemode = 3
.borderstyle = 0
dibget .hdc, 0, 0, .scalewidth, .scaleheight
end with
copydata inputhei, inputwid
picture2.autoredraw = true
dibput picture2.hdc
picture2.refresh
end sub

发表于：2007-11-20 08:46:151楼得分:0

帮顶

发表于：2007-11-20 10:34:392楼得分:0

vb6不能找到dll入口～～
要得到picture1的图像，为什么不用image呢？

发表于：2007-11-20 19:55:403楼得分:0

这样做，不光为输入和输出图像，中间还要对像素进行处理，包括图像缩放、色彩调整、锐化、柔化等等处理，使用两个不同的数组来分别存放数据更有利于程序的实现。

发表于：2007-11-21 11:04:414楼得分:0

getdibits idsource, ibitmap, 0&, h, colval（0, 0, 0), bi24bitinfo, 0&

iamdeane 提醒的对，将ibitmap 换成 picture1.image 就可以了。那下面这个为何不行啊，
ibitmap = getcurrentobject（idsource, 7&)

发表于：2007-11-30 01:11:375楼得分:0

多谢楼主！

发表于：2007-12-02 11:45:096楼得分:0

帮顶

发表于：2007-12-04 15:08:097楼得分:0

public sub dibget（byval idsource as long, xbegin as long, byval ybegin as long, byval xend as long, byval yend as long)
dim ibitmap as long
dim idc as long
dim i as long
dim l as long
dim x as long
dim y as long
dim w as long
dim h as long
dim total as long
dim alignedw as long 'in bytes
'on error goto errline
done = false
timeprocess = timegettime
inputwid = xend - xbegin
inputhei = yend - ybegin
outputhei = inputhei
outputwid = inputwid
w = inputwid + 1
h = inputhei + 1
'alignedw = （（w * 3& + 3&) and （not 3&))
i = （bits \ 8) - 1

redim colval（i, inputwid, inputhei)

with bi24bitinfo.bmiheader
.bibitcount = bits
.bicompression = 0&
.biplanes = 1
.bisize = len（bi24bitinfo.bmiheader)
.biwidth = w
.biheight = h
end with
ibitmap = getcurrentobject（idsource, 7&)
getdibits idsource, ibitmap, 0&, h, colval（0, 0, 0), bi24bitinfo, 0&

deleteobject ibitmap

copydata 1, 3, inputwid, inputhei
copydata 1, 2, inputwid, inputhei
canzoom = true
canput = true
done = true
timeprocess = timegettime - timeprocess
exit sub
errline:
msgbox "错误号：" & err.number & " " & err.description
end sub

public sub dibput（byval iddestination as long)
dim i as long
dim p as long
dim x as long
dim y as long
dim w as long
dim h as long
dim max as long
dim rgbratio（3) as integer
dim vratio as byte
dim col as long
dim dput（) as long
dim linebytes as long '一个扫描行的长度,计算公式：linebytes=（（biwidth*bibitcount+31)and &hffffffe0)\8
'on error goto errline
if not canput then exit sub
if enhanced then vratio = 1 else vratio = valueratio
done = false
timeprocess = timegettime
w = outputwid + 1
h = outputhei + 1
with bi24bitinfo.bmiheader
' .bisize = len（bmpinfo)
.biwidth = w
.biheight = h
' .bibitcount = bits '24位色
' .biplanes = 1
' .bicompression = 0
linebytes = （（w * bits + 31) and &hffffffe0) \ 8
.bisizeimage = linebytes * h
'redim mapdata（w - 1, h - 1, 2)
end with

setdibitstodevice iddestination, 0, 0, w, h, 0, 0, 0, h, colout（0, 0, 0), bi24bitinfo.bmiheader, 0 'dib_rgb_colors
done = true
timeprocess = timegettime - timeprocess
exit sub
errline:
msgbox err.description
end sub

public sub copydata（byval datasrc as long, byval datadst as long, byval w as long, byval h as long)
dim length as long
dim i as long
dim l as long
'on error goto errline
'1：colval 2：coltmp 3：colout
i = bits \ 8
l = i - 1
select case datasrc
case 1: length = （w + 1) * （h + 1) * i '计算数据长度
select case datadst
case 2: redim coltmp（l, w, h)
copymemory coltmp（0, 0, 0), colval（0, 0, 0), length
case 3: redim colout（l, w, h)
copymemory colout（0, 0, 0), colval（0, 0, 0), length
case else: exit sub
end select
case 2: length = w * h * i
select case datadst
case 3: redim colout（l, w, h)
copymemory colout（0, 0, 0), coltmp（0, 0, 0), length
case else: exit sub
end select
case 3: length = w * h * i
select case datadst
case 0: redim mapdata（l, w, h)
copymemory mapdata（0, 0, 0), colout（0, 0, 0), length
case 2: redim coltmp（l, w, h)
copymemory coltmp（0, 0, 0), colout（0, 0, 0), length
case else: exit sub
end select
end select
exit sub
errline:
msgbox err.description
end sub

调用：
dibget picture1.hdc, 0, 0, picture1.width - 1, picture1.height - 1
copydata 1，3
dibput picture2.hdc
picture2.refresh

先调用dibget将picture1中的图像数据读入数组colval中，
再调用copydata将colval拷贝至数组colout，
最后调用dibout将colout中的内容输出到picture2中
刷新picture2

注意，请事先将picture1和2的scalemode设为3，autoredraw设为true

其他资讯