【叶帆开源区】-Gif动画播放控件源码

叶帆 2004-11-11 11:59:59
这段源码也是继承高手而来,不过我增加了好多我自己的东西,并且添加了详细的中文注释(外文咱也不会加:))。
我认为最好的编程学习方法就是学习高手的源码,读人家的思路,掌握人家的方法。
以后有时间,我会陆续发布一些我已整理和添加注释的高手源码。
注:这段源码由于时间比较久了,原作者说明已丢失(是一个国外的高手)

控件说明:http://blog.csdn.net/yefanqiu/archive/2004/11/11/176768.aspx

源码下载:http://blog.csdn.net/yefanqiu 【叶帆源码】- [013]Gif播放控件源码

部分源码:--------------------
'*************************************************************************
'**模 块 名:clsGifs
'**说 明:YFSoft 版权所有2003 - 2004(C)
'**创 建 人:叶帆
'**日 期:2003年04月05日
'**修 改 人:
'**日 期:
'**描 述:Gif播放类模块
'**版 本:版本1.0 http://blog.csdn.net/yefanqiu
'*************************************************************************
Option Explicit

'*************************************************************************
'**所用到的结构体
'*************************************************************************
Private Type RGBQUAD
RGBBlue As Byte
RGBGreen As Byte
RGBRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPFILEHEADER '共14字节
bfType As Integer
bfSize(3) As Byte '原为bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits(3) As Byte '原为bfOffBits As Long
End Type
...

'*************************************************************************
'**API函数声明
'*************************************************************************
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetNearestColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
'删除专用设备场景或信息场景,释放所有相关窗口资源。不要将它用于GetDC函数取回的设备场景
Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
...
'*************************************************************************
'**常数定义
'*************************************************************************
Private Const MAX_PATH = 260
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const CREATE_ALWAYS = 2
...
'*************************************************************************
'**变量定义
'*************************************************************************
'DIB部分的句柄
Private hBMap As Long
'屏幕兼容的DC
Private hdc As Long
Private hDC1 As Long
'最初位图所选择的DC句柄
Private hBmpOrig As Long
'Gif动画播放的开始帧
Private mGifStart() As Long
Private intGifStartNum As Integer
'Gif动画播放的结束帧
Private mGifEnd() As Long
Private intGifEndNum As Integer
Private hStdPicture() As Object
Private intLenNum As Integer 'hStdPicture数组的大小
Private hDCApp As Long
Private lngRet As Long
...

'*************************************************************************
'**函 数 名:RenderGif
'**输 入:无
'**输 出:无
'**功能描述:
'**全局变量:
'**调用模块:
'**作 者:叶帆
'**日 期:2003年04月05日
'**修 改 人:
'**日 期:
'**版 本:版本1.0
'*************************************************************************
Public Sub RenderGif(Optional intFrameNum As Long = -1)
On Error Resume Next
Dim varTemp As Long

Static lngNum As Long '循环变量

If intGifStartNum <= 0 Then
Exit Sub
End If

'设置DC句柄
hDCApp = hdc
hDCtemp = apiCreateCompatibleDC(hdc)


If intFrameNum = -1 Then '循环播放
If lngNum > UBound(mGifStart) Then lngNum = 0
ctr = lngNum
Else '播放指定帧
If intFrameNum < 0 Then intFrameNum = 0
If intFrameNum > UBound(mGifStart) Then intFrameNum = UBound(mGifStart)
ctr = intFrameNum
End If

'==============================================================================================
'循环体

'获得指定对象的结构
lngRet = apiGetObject(hStdPicture(ctr), Len(bm), bm)

'设置信息
hBmpOrig = apiSelectObject(hDCtemp, hStdPicture(ctr))

'释放
Erase bTemparray

'颜色处理
If TransparentColorFlag(ctr) Then
If LocalColorTableFlag(ctr) Then
apiCopyMemory bTemparray(0), LocalColorTable(TransparentColorIndex(ctr) * 3), 3
Else
apiCopyMemory bTemparray(0), GlobalColorTable((TransparentColorIndex(ctr) * 3)), 3
End If
Else
If GlobalColorTableFlag Then
apiCopyMemory bTemparray(0), GlobalColorTable((BackgroundColorIndex * 3)), 3
End If
End If


'设置图片的大小
rc.Bottom = ImageHeight(ctr)
rc.Right = ImageWidth(ctr)
rc.Top = ImageTop(ctr)
rc.Left = ImageLeft(ctr)


'设置背景色
Select Case DisposalMethod(ctr)

Case 0, 1
'空
Case 2
'背景色使用UserControl的背景色--lngTemp
'创建刷子
hBrush = apiCreateSolidBrush(lngTemp)
hOrigBrush = apiSelectObject(hDC1, hBrush)

Dim rcTemp As RECTL
rcTemp.Right = bmap.bmWidth
rcTemp.Bottom = bmap.bmHeight

'填充背景色
lngRet = apiFillRect(hDC1, rcTemp, hBrush)
lngRet = apiDeleteObject(hBrush)
Case 3
'恢复前一帧
Case Else
'空
End Select

'显示颜色
If TransparentColorFlag(ctr) Then
TransparentBlt hDC1, hDCApp, hDCtemp, rc, 0 + rc.Left, 0 + rc.Top, RGB(bTemparray(0), bTemparray(1), bTemparray(2))
Else
lngRet = apiBitBlt(hDC1, rc.Left, rc.Top, rc.Right, rc.Bottom, hDCtemp, 0, 0, SRCCOPY)
lngRet = apiBitBlt(hdc, 0, 0, bmap.bmWidth, bmap.bmHeight, hDC1, 0, 0, SRCCOPY)
DoEvents
End If


'恢复原先的DC
lngRet = apiSelectObject(hDCtemp, hBmpOrig)

If intFrameNum = -1 Then lngNum = lngNum + 1

'==========================================================================================
'释放DC
lngRet = apiReleaseDC(0&, hDCApp)
lngRet = apiDeleteDC(hDCtemp)
End Sub

【叶帆开源区】其它链接

1、XP界面窗体制作(可放缩、可缩小到托盘)
http://community.csdn.net/Expert/topic/3387/3387552.xml?temp=.416424
2、VB源码之友
http://community.csdn.net/Expert/topic/3365/3365079.xml?temp=7.926577E-02
3、定制公用对话框(如photoshop的文件打开对话框)
http://community.csdn.net/Expert/topic/3380/3380429.xml?temp=.3048517
4、MSComm串口通信示例
http://community.csdn.net/Expert/topic/3387/3387736.xml?temp=.2366754
5、任意透明窗体--运用API实现特异窗体
http://community.csdn.net/Expert/topic/3389/3389796.xml?temp=.8869898

...全文
580 点赞 收藏 35
写回复
35 条回复
phlac 2005年05月09日
学习!!!
回复 点赞
cly2004 2005年05月09日
mark
回复 点赞
cuixiping 2005年03月19日
收藏
回复 点赞
tmd007 2005年01月22日
学习
回复 点赞
CatchWind 2005年01月22日
很好.
回复 点赞
shiyunlong 2005年01月22日
收藏
回复 点赞
33184777 2005年01月21日
收藏中!
回复 点赞
xfyxq 2005年01月21日
收藏~
回复 点赞
zzzz123456 2005年01月20日
d
回复 点赞
熊孩子开学喽 2005年01月20日
好东西,收藏之
回复 点赞
aohan 2005年01月19日
支持一下
回复 点赞
yangao 2005年01月19日
楼主牛X
回复 点赞
大王派我去巡山 2005年01月19日
强烈支持!
回复 点赞
BladeMaster_Lee 2005年01月19日
收到!
回复 点赞
aohan 2004年12月16日
顶一下
回复 点赞
CatchWind 2004年12月15日
已下載,非常不錯.
回复 点赞
kmzs 2004年12月15日
不愧高手!
回复 点赞
viewslip 2004年12月15日
好东西,顶!
回复 点赞
openforever 2004年12月14日
谢谢楼主

支持
回复 点赞
叶帆 2004年12月14日
to howtodo12345()

直接过滤还没有好的方法,不过可以把背景的HDC句柄替换控件的HDC,这样可以实现基本的透明
回复 点赞
发动态
发帖子
控件
创建于2007-09-28

1223

社区成员

4.1w+

社区内容

VB 控件
社区公告
暂无公告