为您的图片添加电灯光照效果
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 
|