| 发表于：2007-03-24 17:56:084楼 得分:40 |
option explicit
private declare function getdc lib "user32 " （byval hwnd as long) as long
private declare function deletedc lib "gdi32 " （byval hdc as long) as long
private declare function releasedc lib "user32 " （byval hwnd as long, byval hdc as long) as long
private declare function createcompatibledc lib "gdi32 " （byval hdc as long) as long
private declare function createcompatiblebitmap lib "gdi32 " （byval hdc as long, byval nwidth as long, byval nheight as long) as long
private declare function createsolidbrush lib "gdi32 " （byval crcolor 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 fillrect lib "user32 " （byval hdc as long, lprect as rect, byval hbrush as long) as long
private declare function stretchblt lib "gdi32 " （byval hdc 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 nsrcwidth as long, byval nsrcheight as long, byval dwrop as long) as long
private declare function setstretchbltmode lib "gdi32 " （byval hdc as long, byval nstretchmode as long) as long
private declare function olecreatepictureindirect lib "olepro32.dll " （lppictdesc as pictdesc, riid as any, byval fpictureownshandle as long, ipic as ipicture) as long
private const stretch_andscans = 1
private const stretch_orscans = 2
private const stretch_deletescans = 3
private const stretch_halftone = 4
private type pictdesc
size as long
type as long
hbmporicon as long
hpal as long
end type
private type rect
left as long
top as long
right as long
bottom as long
end type
' 缩放图片
' 参数：源图片,新的高度，新的宽度，是否保持长宽比（默认为保持比例)，保持长宽比时空白区域的填充颜色（默认为白色）
public function stretchpicture（byval pic as stdpicture, byval newwidth as long, byval newheight as long, optional byval keepscale as boolean = true, optional byval fillcolor as ole_color = vbwhite) as stdpicture
dim lngw as long ' 原始图片宽度
dim lngh as long ' 原始图片高度
dim lngneww as long ' 缩略图真实宽度
dim lngnewh as long ' 缩略图真实高度
dim lnghdc1 as long ' 内存dc1
dim lnghdc2 as long ' 内存dc2
dim lnghdcscreen as long ' 屏幕dc
dim lngbmp as long ' 新的位图句柄
dim lngbmpold1 as long ' 原始位图句柄1
dim lngbmpold2 as long ' 原始位图句柄2
dim lngbrush as long ' 填充画刷
dim lngguid（3) as long
dim sngdw as single ' 宽度缩放比
dim sngdh as single ' 高度缩放比
dim objpic as stdpicture
dim udtrect as rect
dim udtpictdesc as pictdesc
' 计算原始图片宽度和高度
lngw = pic.width * 1440 / 2540 / screen.twipsperpixelx
lngh = pic.height * 1440 / 2540 / screen.twipsperpixelx
' 创建两个兼容于屏幕的内存dc
lnghdcscreen = getdc（0)
lnghdc1 = createcompatibledc（lnghdcscreen)
lnghdc2 = createcompatibledc（lnghdcscreen)
' 创建新的位图
lngbmp = createcompatiblebitmap（lnghdcscreen, newwidth, newheight)
' 将位图加入到dc中
lngbmpold1 = selectobject（lnghdc1, pic.handle)
lngbmpold2 = selectobject（lnghdc2, lngbmp)
lngneww = newwidth
lngnewh = newheight
if keepscale then
' 设置缩略图背景色
udtrect.right = newwidth
udtrect.bottom = newheight
lngbrush = createsolidbrush（fillcolor)
fillrect lnghdc2, udtrect, lngbrush
deleteobject lngbrush
' 计算长宽缩放比
sngdw = newwidth / lngw
sngdh = newheight / lngh
' 缩放比使用较小的一个，计算实际图片大小
if sngdw < sngdh then
lngnewh = lngh * sngdw
else
lngneww = lngw * sngdh
end if
end if
' 设置缩放模式，该模式将影响处理速度和生成图片的质量
setstretchbltmode lnghdc2, stretch_halftone
stretchblt lnghdc2, （newwidth - lngneww) / 2, （newheight - lngnewh) / 2, lngneww, lngnewh, lnghdc1, 0, 0, lngw, lngh, vbsrccopy
' 将位图转换成 stdpicture 对象
udtpictdesc.size = len（udtpictdesc)
udtpictdesc.type = vbpictypebitmap
udtpictdesc.hbmporicon = lngbmp
udtpictdesc.hpal = 0
lngguid（0) = &h7bf80980
lngguid（1) = &h101abf32
lngguid（2) = &haa00bb8b
lngguid（3) = &hab0c3000
olecreatepictureindirect udtpictdesc, lngguid（0), true, objpic
selectobject lnghdc1, lngbmpold1
selectobject lnghdc2, lngbmpold2
' 释放gdi对象
deletedc lnghdc1
deletedc lnghdc2
releasedc 0, lnghdcscreen
set stretchpicture = objpic
end function
private sub command1_click（)
set picture2.picture = stretchpicture（picture1.picture, 512, 512, true, vbblack)
end sub
| | |
|
