【叶帆开源区】－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

...全文