IDC资讯中心
为您的图片添加电灯光照效果
http://www.syszedu.net/jiang/dragon/1537.htm
——————————————————————————–
下面便给您设计这种加电灯光照效果的addlightctrol控件。其原理是这样的：图片区域用黑色填充,并在内存中读入一个背景图片,在mouse移动的位置上产生一个圆,并将内存图片相应区域根据黑色、白色渐进原理生成一个光照效果的图片,写用用户图片中。
一、addlightctrol控件的设计
1、启动vb6.0,在工程文件中选中用户控件,并将工程文件设计如下(api.bas见《图片的平滑切换处理技术》一文)：
2、在用户控件界面中添加一个timer和picture控件,分别命名为"timer"、"picctrl"且将picctrl的top和left属性均设置为0。
3、在用户控件code窗体中添加如下代码：
const lens = 70 镜长
const step = 3
private hp as picture
private hback as long
private isfirst, ischage as boolean
private picwidth, picheight as integer
private textlen, startx, maxoffsetx as integer
private lix, liy as integer
缺省属性值:
const m_def_lightsize = lens
const m_def_picturefilename = "c:\jiang\userocx\light\addsnow.jpg"
const m_def_textstring = "为深夜中的图片加电灯光照效果addlightctrol " & _
" v1.0 设计：江龙 2000年1月31日"
const m_def_textoffsety = -1
属性变量:
dim m_picturefilename as string
dim m_textstring as string
dim m_textoffsety as integer
dim m_lightsize as integer
事件声明:
event mousemove(button as integer, shift as integer, x as single, y as single)
mappinginfo=picctrl,picctrl,-1,mousemove
event timer() mappinginfo=timer,timer,-1,timer
private sub usercontrol_initialize()
isfirst = true
hback = 0
ischange = false
set hp = nothing
end sub
注意！不要删除或修改下列被注释的行！
mappinginfo=picctrl,picctrl,-1,borderstyle
public property get borderstyle() as integer
borderstyle = picctrl.borderstyle
end property
public property let borderstyle(byval new_borderstyle as integer)
picctrl.borderstyle() = new_borderstyle
propertychanged "borderstyle"
end property
注意！不要删除或修改下列被注释的行！
mappinginfo=picctrl,picctrl,-1,fontname
public property get fontname() as string
fontname = picctrl.fontname
end property
public property let fontname(byval new_fontname as string)
picctrl.cls
picctrl.fontname() = new_fontname
propertychanged "fontname"
end property
注意！不要删除或修改下列被注释的行！
mappinginfo=picctrl,picctrl,-1,fontsize
public property get fontsize() as single
fontsize = picctrl.fontsize
end property
public property let fontsize(byval new_fontsize as single)
picctrl.cls
picctrl.fontsize() = new_fontsize
maxoffsetx = picctrl.textwidth(m_textstring)
propertychanged "fontsize"
end property
注意！不要删除或修改下列被注释的行！
mappinginfo=timer,timer,-1,interval
public property get speed() as long
speed = timer.interval
end property
public property let speed(byval new_speed as long)
timer.interval() = new_speed
propertychanged "speed"
end property
注意！不要删除或修改下列被注释的行！
memberinfo=13,0,0,"图片过度效果pictrans v1.0 设计：江龙 2000年02月30日"
public property get textstring() as string
textstring = m_textstring
end property
public property let textstring(byval new_textstring as string)
picctrl.cls
m_textstring = new_textstring
textlen = strlen(m_textstring)
maxoffsetx = picctrl.textwidth(m_textstring)
propertychanged "textstring"
end property
注意！不要删除或修改下列被注释的行！
mappinginfo=picctrl,picctrl,-1,forecolor
public property get textcolor() as ole_color
textcolor = picctrl.forecolor
end property
public property let textcolor(byval new_textcolor as ole_color)
picctrl.forecolor() = new_textcolor
propertychanged "textcolor"
end property
注意！不要删除或修改下列被注释的行！
memberinfo=7,0,0,0
public property get textoffsety() as integer
textoffsety = m_textoffsety
end property
public property let textoffsety(byval new_textoffsety as integer)
if (new_textoffsety < 0) then
m_textoffsety = -1
else
m_textoffsety = new_textoffsety
end if
picctrl.cls
propertychanged "textoffsety"
end property
为用户控件初始化属性
private sub usercontrol_initproperties()
m_textstring = m_def_textstring
m_textoffsety = m_def_textoffsety
m_picturefilename = m_def_picturefilename
m_lightsize = m_def_lightsize
end sub
从存贮器中加载属性值
private sub usercontrol_readproperties(propbag as propertybag)
picctrl.borderstyle = propbag.readproperty("borderstyle", 1)
picctrl.fontname = propbag.readproperty("fontname", "宋体")
picctrl.fontsize = propbag.readproperty("fontsize", 9)
timer.interval = propbag.readproperty("speed", 50)
m_textstring = propbag.readproperty("textstring", m_def_textstring)
picctrl.forecolor = propbag.readproperty("textcolor", &h80000012)
m_textoffsety = propbag.readproperty("textoffsety", m_def_textoffsety)
m_picturefilename = propbag.readproperty("picturefilename", m_def_picturefilename)
m_lightsize = propbag.readproperty("lightsize", m_def_lightsize)
end sub
private sub usercontrol_show()
on error resume next
if isfirst then 是第一次
startx = picwidth
isfirst = false
set hp = loadpicture(m_picturefilename) 装入图片
if err then
set hp = nothing
end if
textlen = strlen(m_textstring)
lix = picwidth \ 2
liy = picheight \ 2
maxoffsetx = picctrl.textwidth(m_textstring)
end if
end sub
private sub usercontrol_terminate()
if not (hp is nothing) then set hp = nothing
if hback <> 0 then call deleteobject(hback)
end sub
将属性值写到存储器
private sub usercontrol_writeproperties(propbag as propertybag)
call propbag.writeproperty("borderstyle", picctrl.borderstyle, 1)
call propbag.writeproperty("fontname", picctrl.fontname, "宋体")
call propbag.writeproperty("fontsize", picctrl.fontsize, 9)
call propbag.writeproperty("speed", timer.interval, 50)
call propbag.writeproperty("textstring", m_textstring, m_def_textstring)
call propbag.writeproperty("textcolor", picctrl.forecolor, &h80000012)
call propbag.writeproperty("textoffsety", m_textoffsety, m_def_textoffsety)
call propbag.writeproperty("picturefilename", m_picturefilename, m_def_picturefilename)
call propbag.writeproperty("lightsize", m_lightsize, m_def_lightsize)
end sub
private sub timer_timer()
dim m as integer
dim sm as string
if ischange then exit sub
if startx < -maxoffsetx – picwidth then 图片已切换完，则换源和目的
startx = picwidth
end if
startx = startx – step 下一步
if m_textoffsety < 0 then
m = picheight – picctrl.fontsize – 5
else
m = m_textoffsety
end if
if hp is nothing then
sm = m_picturefilename & "不能装入"
call textout(picctrl.hdc, 0, m, sm, strlen(sm))
else
lix = lix + rnd * m_lightsize – m_lightsize / 2
liy = liy + rnd * m_lightsize – m_lightsize / 2
call gettransbitmap(lix, liy)
call textout(picctrl.hdc, startx, m, m_textstring, textlen)
end if
raiseevent timer
end sub
private sub usercontrol_resize()
dim hdc, hbrush as long
on error resume next
picctrl.height = height
picctrl.width = width
picwidth = int(picctrl.scalewidth + 1)
picheight = int(picctrl.scaleheight + 1)
if hback then deleteobject hback
hback = createcompatiblebitmap(picctrl.hdc, picwidth, picheight) 建立位置
end sub
获取颜效果图形
private sub gettransbitmap(byval x as integer, byval y as integer)
dim s, mx, my, ty, tx, len2, r, g, b as integer
dim i, j, maxlen as integer
dim n, hdc, hbackdc, srccolor, dstcolor, curcolor as long
if hp is nothing then exit sub
hdc = createcompatibledc(picctrl.hdc) 建立一个兼容的图片dc
call selectobject(hdc, hp)
hbackdc = createcompatibledc(picctrl.hdc) 建立一个兼容的dc
call selectobject(hbackdc, hback) 将背景清为黑色
call patblt(hbackdc, 0, 0, picwidth, picheight, blackness)
len2 = m_lightsize \ 2
mx = x + len2
my = y + len2
l2 = (len2 + 1) \ 2
for j = 0 to m_lightsize – 1
ty = y + j
if ty >= 0 and ty < picwidth then
for i = 0 to m_lightsize – 1
tx = i + x
if tx >= 0 and tx < picwidth then
s = int(sqr((tx – mx) * (tx – mx) + (ty – my) * (ty – my)) + 0.5)
srccolor = getpixel(hdc, tx, ty)
if srccolor < 0 then srccolor = 0
if s > len2 then
s = len2
else
if s < 0 then s = 0
end if
if s < l2 then
curcolor = gettriencolor(srccolor, rgb(255, 255, 255), l2, l2 – s)
else
s = s – l2
curcolor = gettriencolor(rgb(0, 0, 0), srccolor, l2, l2 – s)
end if
call setpixel(hbackdc, tx, ty, curcolor)
end if
next i
end if
next j
call bitblt(picctrl.hdc, 0, 0, picwidth, picheight, hbackdc, 0, 0, srccopy)
call deletedc(hdc)
call deletedc(hbackdc)
end sub
注意！不要删除或修改下列被注释的行！
memberinfo=13,0,0,""
public property get picturefilename() as string
picturefilename = m_picturefilename
end property
public property let picturefilename(byval new_picturefilename as string)
on error resume next
dim old as boolean
m_picturefilename = new_picturefilename
if hp is nothing then old = true else old = false
set hp = loadpicture(new_picturefilename)
if err then
picctrl.cls
set hp = nothing
else
if old then startx = picwidth
end if
propertychanged "picturefilename"
end property
private sub picctrl_mousemove(button as integer,
shift as integer, x as single, y as single)
ischange = true
call gettransbitmap(x – m_lightsize / 2, y – m_lightsize / 2)
lix = x
liy = y
raiseevent mousemove(button, shift, x, y)
ischange = false
end sub
注意！不要删除或修改下列被注释的行！
memberinfo=7,0,0,0
public property get lightsize() as integer
lightsize = m_lightsize
end property
public property let lightsize(byval new_lightsize as integer)
if new_lightsize < 10 or new_lightsize > 150 then
m_lightsize = lens
else
m_lightsize = new_lightsize
end if
propertychanged "lightsize"
end property
注意！不要删除或修改下列被注释的行！
memberinfo=14
public function aboutbox() as variant
msgbox "add light for picture ctrol v1.0 by dragonjiang" & chr(13) &
"date: 2000.01.31", vbinformation
end function
4、选中文件中的生成"*.ocx ",将文件生成ocx控件。
二、测试您的addlightctrol.ocx
1、新建一个标准exe工程,工程/部件中引入自己的addlightctrol.ocx;
2、将窗体设计如下：
3、双击用户窗体,在窗体code中加入如下代码：
private sub about_click()
addlight.aboutbox
end sub
private sub openbutton_click()
on error goto exitopen
dlg.filter = "所有的图形文件|(*.bmp;*.jpg;*.wfm;*.emf;*.ico;*.rle;*.gif;*.cur)" & _
"|jpeg文件|*.jpg|bmp文件|(*.bmp)|gif文件|*.gif|光标(*.ico)和图标(*.cur)文件" & _
"|(*.cur,*.ico)|wmf元文件(*.wmf,*.emf)|(*.wmf,*.emf)|rle行程文件(*.rle)|*.rle"
dlg.showopen
addlight.picturefilename = dlg.filename
exitopen:
end sub
private sub font_click()
on error goto exitfont
dlg.flags = cdlcfboth
dlg.showfont
addlight.fontname = dlg.fontname
addlight.fontsize = dlg.fontsize
exitfont:
end sub
private sub form_load()
addlight.picturefilename = app.path & "\addsnow.jpg"
dlg.cancelerror = true
updown(1).value = addlight.speed
updown(0).value = addlight.textoffsety
updown(2).value = addlight.lightsize
textcolor.backcolor = addlight.textcolor
textstring.text = addlight.textstring
dlg.initdir = app.path
end sub
private sub textcolor_click()
on error goto exitcolor
dlg.showcolor
addlight.textcolor = dlg.color
textcolor.backcolor = dlg.color
exitcolor:
end sub
private sub textstring_change()
addlight.textstring = textstring.text
end sub
private sub updown_change(i as integer)
dim n as integer
textval(i).text = updown(i).value
n = updown(i).value
select case i
case 0
addlight.textoffsety = n
case 1
addlight.speed = n
case 2
addlight.lightsize = n
end select
end sub
4、至此您的测试程序完成,按下play。^_^, 灯光移过的地方(mouse移动时), 图片真的出来啦！(2000年2月完稿，本文发表于《电脑编程技术与维护》2000年第8期)
word版文档下载地址：http://www.i0713.net/download/prog/dragon/doc/addlight.doc
源程序文档下载地址：http://www.i0713.net/download/prog/dragon/prog/addlight.zip
