为您的图片添加电灯光照效果
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
本文地址：http://com.8s8s.com/it/it44573.htm