为您的图片添加电灯光照效果

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)文件" & _

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