7,763
社区成员
发帖
与我相关
我的任务
分享请发表友善的回复…
发表回复
AechoJohn 2003-07-16
- 打赏
- 举报
最好找个Gif89a.dll这样的控件来用,它专门放Gif动画的.
liu_swallow 2003-07-16
- 打赏
- 举报
有
liu_swallow 2003-07-16
- 打赏
- 举报
thanks
道素 2003-07-15
- 打赏
- 举报
Private Sub pvReadBuffer(ByVal pAddr As Long, ByVal lSize)
Const FUNC_NAME As String = "pvReadBuffer"
Dim lIdx As Long
On Error GoTo EH
'--- read from stream to local buffer
ReDim aBuf(0 To lSize) As Byte
For lIdx = 0 To lSize - 1
aBuf(lIdx) = pvReadByte()
Next
'--- copy if necessary
If pAddr <> 0 Then
CopyMemory ByVal pAddr, aBuf(0), lSize
End If
Exit Sub
EH:
RaiseError FUNC_NAME
End Sub
Private Function pvReadSubBlockByte() As Byte
Const FUNC_NAME As String = "pvReadSubBlockByte"
On Error GoTo EH
If m_lSubBlockSize <= 0 Then
m_lSubBlockSize = pvReadByte()
'--- workaround for 3D Studio R4's non-compliant GIFs
If m_lSubBlockSize = 0 Then
m_lSubBlockSize = 256
End If
End If
pvReadSubBlockByte = pvReadByte()
m_lSubBlockSize = m_lSubBlockSize - 1
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Sub pvCloseFile()
Const FUNC_NAME As String = "pvCloseFile"
On Error GoTo EH
If m_nFile <> 0 Then
Close #m_nFile
m_nFile = 0
End If
Exit Sub
EH:
RaiseError FUNC_NAME
End Sub
Private Sub pvSkipBlock()
Do
m_lSubBlockSize = pvReadByte()
Seek #m_nFile, Seek(m_nFile) + m_lSubBlockSize
Loop While m_lSubBlockSize > 0
End Sub
'= LZW decompressor ======================================================
Private Function pvLzwReadCode() As Long
Const FUNC_NAME As String = "pvLzwReadCode"
On Error GoTo EH
Do While m_lInputBitCount < m_lCurrentBits
m_lInputBitBuffer = m_lInputBitBuffer Or (pvReadSubBlockByte() * m_aPOT(m_lInputBitCount))
m_lInputBitCount = m_lInputBitCount + 8
Loop
pvLzwReadCode = m_lInputBitBuffer And (m_aPOT(m_lCurrentBits) - 1)
m_lInputBitBuffer = m_lInputBitBuffer \ m_aPOT(m_lCurrentBits)
m_lInputBitCount = m_lInputBitCount - m_lCurrentBits
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Function pvLzwDecodeString(aStack() As Byte, ByVal lIdx As Long, _
ByVal lCode As Long) As Long
Const FUNC_NAME As String = "pvLzwDecodeString"
On Error GoTo EH
Do While lCode >= m_lClearTable
aStack(lIdx) = m_aAppendChar(lCode)
lIdx = lIdx + 1
lCode = m_aPrefixCode(lCode)
If lIdx > UBound(aStack) Then
Err.Raise vbObjectError + 2, , ERR_PAST_END_OF_STACK
End If
Loop
aStack(lIdx) = lCode
pvLzwDecodeString = lIdx
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Sub pvLzwExpand(aBuffer() As Byte, ByVal lBufSize)
Const FUNC_NAME As String = "pvLzwExpand"
Dim lIdx As Long
Dim lNewCode As Long
Dim lOldCode As Long
Dim lNextCode As Long
Dim bCharacter As Byte
Dim bClearFlag As Boolean
Dim aStack(0 To 4000) As Byte
Dim lStackIdx As Long
Dim lPrevProgess As Long
On Error GoTo EH
lNextCode = m_lClearTable + 2 '--- first code = m_lClearTable + 2
bClearFlag = True
lNewCode = pvLzwReadCode()
Do While lIdx < lBufSize
lNewCode = pvLzwReadCode()
'--- check for terminator
If lNewCode = m_lClearTable + 1 Then '--- terminator = m_lClearTable + 1
Exit Sub
End If
If bClearFlag Then
bClearFlag = False
lOldCode = lNewCode
bCharacter = lNewCode
aBuffer(lIdx) = bCharacter
lIdx = lIdx + 1
ElseIf lNewCode = m_lClearTable Then
bClearFlag = True
m_lCurrentBits = m_lInitBits
m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
lNextCode = m_lClearTable + 2 '--- first code = m_lClearTable + 2
Else
'--- decode string
If lNewCode < lNextCode Then
lStackIdx = pvLzwDecodeString(aStack, 0, lNewCode)
ElseIf lNewCode = lNextCode Then
aStack(0) = bCharacter
lStackIdx = pvLzwDecodeString(aStack, 1, lOldCode)
Else
Err.Raise vbObjectError + 3, , ERR_INVALID_LZW_CODE
End If
'--- save first char
bCharacter = aStack(lStackIdx)
'--- reverse copy stack
Do While lStackIdx >= 0
aBuffer(lIdx) = aStack(lStackIdx)
lStackIdx = lStackIdx - 1
lIdx = lIdx + 1
Loop
'--- keep char table up-to-date
m_aPrefixCode(lNextCode) = lOldCode
m_aAppendChar(lNextCode) = bCharacter
lNextCode = lNextCode + 1
'--- expand code bitsize if max reached
If lNextCode > m_lMaxCode Then
If m_lCurrentBits < MAX_BITS Then
m_lCurrentBits = m_lCurrentBits + 1
m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
End If
End If
lOldCode = lNewCode
End If
'--- report progress
lStackIdx = lIdx \ ImageWidth
If lStackIdx >= lPrevProgess + 10 Then
RaiseEvent Progress(lStackIdx)
lPrevProgess = lStackIdx
End If
Loop
Exit Sub
EH:
RaiseError FUNC_NAME
End Sub
'=========================================================================
' Base class events
'=========================================================================
Private Sub Class_Initialize()
Dim lIdx As Long
'--- init look-up table for fast 2 ^ x
m_aPOT(-1) = 0
m_aPOT(0) = 1
For lIdx = 1 To 30
m_aPOT(lIdx) = 2 * m_aPOT(lIdx - 1)
Next
m_aPOT(31) = &H80000000
End Sub
Private Sub Class_Terminate()
Dim lErrNum As Long
Dim sErrSrc As String
Dim sErrDesc As String
'--- preserve error info and try not to throw one
'--- best practices: "destructors are never throwing an exception"
lErrNum = Err.Number
sErrSrc = Err.Source
sErrDesc = Err.Description
On Error Resume Next
pvCloseFile
On Error GoTo 0
Err.Number = lErrNum
Err.Source = sErrSrc
Err.Description = sErrDesc
End Sub
我以前做了一个控件,找不到了
Const FUNC_NAME As String = "pvReadBuffer"
Dim lIdx As Long
On Error GoTo EH
'--- read from stream to local buffer
ReDim aBuf(0 To lSize) As Byte
For lIdx = 0 To lSize - 1
aBuf(lIdx) = pvReadByte()
Next
'--- copy if necessary
If pAddr <> 0 Then
CopyMemory ByVal pAddr, aBuf(0), lSize
End If
Exit Sub
EH:
RaiseError FUNC_NAME
End Sub
Private Function pvReadSubBlockByte() As Byte
Const FUNC_NAME As String = "pvReadSubBlockByte"
On Error GoTo EH
If m_lSubBlockSize <= 0 Then
m_lSubBlockSize = pvReadByte()
'--- workaround for 3D Studio R4's non-compliant GIFs
If m_lSubBlockSize = 0 Then
m_lSubBlockSize = 256
End If
End If
pvReadSubBlockByte = pvReadByte()
m_lSubBlockSize = m_lSubBlockSize - 1
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Sub pvCloseFile()
Const FUNC_NAME As String = "pvCloseFile"
On Error GoTo EH
If m_nFile <> 0 Then
Close #m_nFile
m_nFile = 0
End If
Exit Sub
EH:
RaiseError FUNC_NAME
End Sub
Private Sub pvSkipBlock()
Do
m_lSubBlockSize = pvReadByte()
Seek #m_nFile, Seek(m_nFile) + m_lSubBlockSize
Loop While m_lSubBlockSize > 0
End Sub
'= LZW decompressor ======================================================
Private Function pvLzwReadCode() As Long
Const FUNC_NAME As String = "pvLzwReadCode"
On Error GoTo EH
Do While m_lInputBitCount < m_lCurrentBits
m_lInputBitBuffer = m_lInputBitBuffer Or (pvReadSubBlockByte() * m_aPOT(m_lInputBitCount))
m_lInputBitCount = m_lInputBitCount + 8
Loop
pvLzwReadCode = m_lInputBitBuffer And (m_aPOT(m_lCurrentBits) - 1)
m_lInputBitBuffer = m_lInputBitBuffer \ m_aPOT(m_lCurrentBits)
m_lInputBitCount = m_lInputBitCount - m_lCurrentBits
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Function pvLzwDecodeString(aStack() As Byte, ByVal lIdx As Long, _
ByVal lCode As Long) As Long
Const FUNC_NAME As String = "pvLzwDecodeString"
On Error GoTo EH
Do While lCode >= m_lClearTable
aStack(lIdx) = m_aAppendChar(lCode)
lIdx = lIdx + 1
lCode = m_aPrefixCode(lCode)
If lIdx > UBound(aStack) Then
Err.Raise vbObjectError + 2, , ERR_PAST_END_OF_STACK
End If
Loop
aStack(lIdx) = lCode
pvLzwDecodeString = lIdx
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Sub pvLzwExpand(aBuffer() As Byte, ByVal lBufSize)
Const FUNC_NAME As String = "pvLzwExpand"
Dim lIdx As Long
Dim lNewCode As Long
Dim lOldCode As Long
Dim lNextCode As Long
Dim bCharacter As Byte
Dim bClearFlag As Boolean
Dim aStack(0 To 4000) As Byte
Dim lStackIdx As Long
Dim lPrevProgess As Long
On Error GoTo EH
lNextCode = m_lClearTable + 2 '--- first code = m_lClearTable + 2
bClearFlag = True
lNewCode = pvLzwReadCode()
Do While lIdx < lBufSize
lNewCode = pvLzwReadCode()
'--- check for terminator
If lNewCode = m_lClearTable + 1 Then '--- terminator = m_lClearTable + 1
Exit Sub
End If
If bClearFlag Then
bClearFlag = False
lOldCode = lNewCode
bCharacter = lNewCode
aBuffer(lIdx) = bCharacter
lIdx = lIdx + 1
ElseIf lNewCode = m_lClearTable Then
bClearFlag = True
m_lCurrentBits = m_lInitBits
m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
lNextCode = m_lClearTable + 2 '--- first code = m_lClearTable + 2
Else
'--- decode string
If lNewCode < lNextCode Then
lStackIdx = pvLzwDecodeString(aStack, 0, lNewCode)
ElseIf lNewCode = lNextCode Then
aStack(0) = bCharacter
lStackIdx = pvLzwDecodeString(aStack, 1, lOldCode)
Else
Err.Raise vbObjectError + 3, , ERR_INVALID_LZW_CODE
End If
'--- save first char
bCharacter = aStack(lStackIdx)
'--- reverse copy stack
Do While lStackIdx >= 0
aBuffer(lIdx) = aStack(lStackIdx)
lStackIdx = lStackIdx - 1
lIdx = lIdx + 1
Loop
'--- keep char table up-to-date
m_aPrefixCode(lNextCode) = lOldCode
m_aAppendChar(lNextCode) = bCharacter
lNextCode = lNextCode + 1
'--- expand code bitsize if max reached
If lNextCode > m_lMaxCode Then
If m_lCurrentBits < MAX_BITS Then
m_lCurrentBits = m_lCurrentBits + 1
m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
End If
End If
lOldCode = lNewCode
End If
'--- report progress
lStackIdx = lIdx \ ImageWidth
If lStackIdx >= lPrevProgess + 10 Then
RaiseEvent Progress(lStackIdx)
lPrevProgess = lStackIdx
End If
Loop
Exit Sub
EH:
RaiseError FUNC_NAME
End Sub
'=========================================================================
' Base class events
'=========================================================================
Private Sub Class_Initialize()
Dim lIdx As Long
'--- init look-up table for fast 2 ^ x
m_aPOT(-1) = 0
m_aPOT(0) = 1
For lIdx = 1 To 30
m_aPOT(lIdx) = 2 * m_aPOT(lIdx - 1)
Next
m_aPOT(31) = &H80000000
End Sub
Private Sub Class_Terminate()
Dim lErrNum As Long
Dim sErrSrc As String
Dim sErrDesc As String
'--- preserve error info and try not to throw one
'--- best practices: "destructors are never throwing an exception"
lErrNum = Err.Number
sErrSrc = Err.Source
sErrDesc = Err.Description
On Error Resume Next
pvCloseFile
On Error GoTo 0
Err.Number = lErrNum
Err.Source = sErrSrc
Err.Description = sErrDesc
End Sub
我以前做了一个控件,找不到了
道素 2003-07-15
- 打赏
- 举报
'--- note: usually this is interpreted as 'gif animation is looped'
Property Get UserInput() As Boolean
UserInput = (pvGetFlag(m_uGraphicControl.bFlags, ucsGflUserInput) <> 0)
End Property
Property Get DisposalMethod() As UcsGifDisposalMethod
DisposalMethod = pvGetFlag(m_uGraphicControl.bFlags, ucsGflDisposalMethod)
End Property
Property Get ImageLut() As Byte()
ImageLut = m_aImageLut
End Property
Property Get ImageBits() As Byte()
ImageBits = m_aImageBits
End Property
Property Get FrameIndex() As Long
FrameIndex = m_lFrameIndex
End Property
Property Get EOF() As Boolean
EOF = m_bEOF
End Property
Property Get DelayTime() As Long
DelayTime = m_uGraphicControl.nDelayTime
End Property
'=========================================================================
' Methods
'=========================================================================
Private Function pvFileExists(sFileName As String) As Boolean
On Error Resume Next
pvFileExists = (GetAttr(sFileName) <> -1)
On Error GoTo 0
End Function
Public Function Init(sFileName As String) As Boolean
Const FUNC_NAME As String = "Init"
Dim lIdx As Long
Dim bColor As Boolean
On Error GoTo EH
'--- init/clear member vars
m_sFileName = sFileName
FillMemory m_uImageDesc, Len(m_uImageDesc), 0
FillMemory m_uGraphicControl, Len(m_uGraphicControl), 0
m_lFrameIndex = -1
m_bEOF = False
'--- check if file exists
If Not pvFileExists(sFileName) Then
Exit Function
End If
'--- open file (first close previous)
pvCloseFile
m_nFile = FreeFile()
Open FileName For Binary As #m_nFile
'--- get file header
pvReadBuffer VarPtr(m_uHeader), Len(m_uHeader) '--- 13
If SigVersion <> STR_GIF87A And SigVersion <> STR_GIF89A Then
Err.Raise vbObject, , ERR_INVALID_GIF_FILE
End If
'--- get global LUT
If HasGlobalLut Then
pvReadBuffer VarPtr(m_aGlobalLut(0)), 3 * GlobalLutSize
End If
m_lFirstFrameLoc = Seek(m_nFile)
'--- success
Init = True
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Public Function MoveNext() As Boolean
Const FUNC_NAME As String = "MoveNext"
On Error GoTo EH
'--- check if anything's left
If m_nFile = 0 Or m_bEOF Then
Exit Function
End If
Do While True
Select Case pvReadByte()
Case ucsGblImageBlock
m_lFrameIndex = m_lFrameIndex + 1
'--- get image desc
pvReadBuffer VarPtr(m_uImageDesc), Len(m_uImageDesc) '--- 9
'--- get image LUT
If HasLocalLut Then
pvReadBuffer VarPtr(m_aImageLut(0)), 3 * LocalLutSize
Else
CopyMemory m_aImageLut(0), m_aGlobalLut(0), 3 * 256
End If
'--- init vars for LZW decoding
m_lInitBits = pvReadByte() + 1
m_lClearTable = m_aPOT(m_lInitBits - 1)
m_lInputBitCount = 0
m_lInputBitBuffer = 0
m_lCurrentBits = m_lInitBits
m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
m_lSubBlockSize = 0
ReDim m_aImageBits(0 To ImageWidth * ImageHeight)
pvLzwExpand m_aImageBits, UBound(m_aImageBits)
'--- read to the end of block
Do
'--- skip to the end end of sub-block
Do While m_lSubBlockSize > 0
pvReadSubBlockByte
Loop
'--- check for block terminator
m_lSubBlockSize = pvReadByte()
Loop While m_lSubBlockSize > 0
RaiseEvent ImageComplete
Exit Do
Case ucsGblExtension
'--- look for 'Graphic Control Label' extension
Select Case pvReadByte()
Case ucsGexGraphicsControl
'--- fill member struct
pvReadBuffer VarPtr(m_uGraphicControl), Len(m_uGraphicControl)
Case Else
'--- unknown extension
pvSkipBlock
End Select
Case ucsGblTrailer
m_bEOF = True
Exit Function
Case 0 '--- silence this just in case
Debug.Print MODULE_NAME; "."; FUNC_NAME; ": "; ERR_UNEXPECTED_BLOCK; " = 0"
Case Else
Err.Raise vbObjectError + 1, , ERR_UNEXPECTED_BLOCK
End Select
Loop
'--- success
MoveNext = True
Exit Function
EH:
m_bEOF = True
RaiseError FUNC_NAME
End Function
Public Function MoveFirst() As Boolean
Const FUNC_NAME As String = "MoveFirst"
On Error GoTo EH
'--- state check
If m_nFile = 0 Then
Exit Function
End If
Seek #m_nFile, m_lFirstFrameLoc
m_lFrameIndex = -1
m_bEOF = False
'--- success
MoveFirst = True
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Public Function MoveLast() As Long
Const FUNC_NAME As String = "MoveLast"
On Error GoTo EH
'--- state check
If m_nFile = 0 Then
Exit Function
End If
If Not EOF Then
Do While True
Select Case pvReadByte()
Case ucsGblImageBlock
m_lFrameIndex = m_lFrameIndex + 1
pvReadBuffer VarPtr(m_uImageDesc), Len(m_uImageDesc) '--- 9
If HasLocalLut Then
pvReadBuffer VarPtr(m_aImageLut(0)), 3 * LocalLutSize
End If
pvReadByte '--- initial bits
pvSkipBlock
Case ucsGblExtension
pvReadByte '--- extension type
pvSkipBlock
Case ucsGblTrailer
m_bEOF = True
Exit Do
Case 0
Case Else
Err.Raise vbObjectError + 1, , ERR_UNEXPECTED_BLOCK
End Select
Loop
End If
'--- success
MoveLast = True
Exit Function
EH:
RaiseError FUNC_NAME
End Function
'= private ===============================================================
Private Function pvGetFlag(ByVal lFlags As Long, ByVal lMask As UcsGifFlags) As Long
If lMask > 0 Then
pvGetFlag = (lFlags And lMask)
Do While (lMask And 1) = 0
lMask = lMask \ 2
pvGetFlag = pvGetFlag \ 2
Loop
End If
End Function
Private Function pvPadScanline(ByVal lOffset As Long)
'--- DIB section horizontal scanline padding to dword
pvPadScanline = (lOffset + 3) And (Not 3)
End Function
'= I/O handling ==========================================================
Private Function pvReadByte() As Byte
Const FUNC_NAME As String = "pvReadByte"
On Error GoTo EH
If VBA.EOF(m_nFile) Then
Err.Raise vbObjectError + 4, , ERR_INPUT_PAST_EOF
End If
Get #m_nFile, , pvReadByte
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Property Get UserInput() As Boolean
UserInput = (pvGetFlag(m_uGraphicControl.bFlags, ucsGflUserInput) <> 0)
End Property
Property Get DisposalMethod() As UcsGifDisposalMethod
DisposalMethod = pvGetFlag(m_uGraphicControl.bFlags, ucsGflDisposalMethod)
End Property
Property Get ImageLut() As Byte()
ImageLut = m_aImageLut
End Property
Property Get ImageBits() As Byte()
ImageBits = m_aImageBits
End Property
Property Get FrameIndex() As Long
FrameIndex = m_lFrameIndex
End Property
Property Get EOF() As Boolean
EOF = m_bEOF
End Property
Property Get DelayTime() As Long
DelayTime = m_uGraphicControl.nDelayTime
End Property
'=========================================================================
' Methods
'=========================================================================
Private Function pvFileExists(sFileName As String) As Boolean
On Error Resume Next
pvFileExists = (GetAttr(sFileName) <> -1)
On Error GoTo 0
End Function
Public Function Init(sFileName As String) As Boolean
Const FUNC_NAME As String = "Init"
Dim lIdx As Long
Dim bColor As Boolean
On Error GoTo EH
'--- init/clear member vars
m_sFileName = sFileName
FillMemory m_uImageDesc, Len(m_uImageDesc), 0
FillMemory m_uGraphicControl, Len(m_uGraphicControl), 0
m_lFrameIndex = -1
m_bEOF = False
'--- check if file exists
If Not pvFileExists(sFileName) Then
Exit Function
End If
'--- open file (first close previous)
pvCloseFile
m_nFile = FreeFile()
Open FileName For Binary As #m_nFile
'--- get file header
pvReadBuffer VarPtr(m_uHeader), Len(m_uHeader) '--- 13
If SigVersion <> STR_GIF87A And SigVersion <> STR_GIF89A Then
Err.Raise vbObject, , ERR_INVALID_GIF_FILE
End If
'--- get global LUT
If HasGlobalLut Then
pvReadBuffer VarPtr(m_aGlobalLut(0)), 3 * GlobalLutSize
End If
m_lFirstFrameLoc = Seek(m_nFile)
'--- success
Init = True
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Public Function MoveNext() As Boolean
Const FUNC_NAME As String = "MoveNext"
On Error GoTo EH
'--- check if anything's left
If m_nFile = 0 Or m_bEOF Then
Exit Function
End If
Do While True
Select Case pvReadByte()
Case ucsGblImageBlock
m_lFrameIndex = m_lFrameIndex + 1
'--- get image desc
pvReadBuffer VarPtr(m_uImageDesc), Len(m_uImageDesc) '--- 9
'--- get image LUT
If HasLocalLut Then
pvReadBuffer VarPtr(m_aImageLut(0)), 3 * LocalLutSize
Else
CopyMemory m_aImageLut(0), m_aGlobalLut(0), 3 * 256
End If
'--- init vars for LZW decoding
m_lInitBits = pvReadByte() + 1
m_lClearTable = m_aPOT(m_lInitBits - 1)
m_lInputBitCount = 0
m_lInputBitBuffer = 0
m_lCurrentBits = m_lInitBits
m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
m_lSubBlockSize = 0
ReDim m_aImageBits(0 To ImageWidth * ImageHeight)
pvLzwExpand m_aImageBits, UBound(m_aImageBits)
'--- read to the end of block
Do
'--- skip to the end end of sub-block
Do While m_lSubBlockSize > 0
pvReadSubBlockByte
Loop
'--- check for block terminator
m_lSubBlockSize = pvReadByte()
Loop While m_lSubBlockSize > 0
RaiseEvent ImageComplete
Exit Do
Case ucsGblExtension
'--- look for 'Graphic Control Label' extension
Select Case pvReadByte()
Case ucsGexGraphicsControl
'--- fill member struct
pvReadBuffer VarPtr(m_uGraphicControl), Len(m_uGraphicControl)
Case Else
'--- unknown extension
pvSkipBlock
End Select
Case ucsGblTrailer
m_bEOF = True
Exit Function
Case 0 '--- silence this just in case
Debug.Print MODULE_NAME; "."; FUNC_NAME; ": "; ERR_UNEXPECTED_BLOCK; " = 0"
Case Else
Err.Raise vbObjectError + 1, , ERR_UNEXPECTED_BLOCK
End Select
Loop
'--- success
MoveNext = True
Exit Function
EH:
m_bEOF = True
RaiseError FUNC_NAME
End Function
Public Function MoveFirst() As Boolean
Const FUNC_NAME As String = "MoveFirst"
On Error GoTo EH
'--- state check
If m_nFile = 0 Then
Exit Function
End If
Seek #m_nFile, m_lFirstFrameLoc
m_lFrameIndex = -1
m_bEOF = False
'--- success
MoveFirst = True
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Public Function MoveLast() As Long
Const FUNC_NAME As String = "MoveLast"
On Error GoTo EH
'--- state check
If m_nFile = 0 Then
Exit Function
End If
If Not EOF Then
Do While True
Select Case pvReadByte()
Case ucsGblImageBlock
m_lFrameIndex = m_lFrameIndex + 1
pvReadBuffer VarPtr(m_uImageDesc), Len(m_uImageDesc) '--- 9
If HasLocalLut Then
pvReadBuffer VarPtr(m_aImageLut(0)), 3 * LocalLutSize
End If
pvReadByte '--- initial bits
pvSkipBlock
Case ucsGblExtension
pvReadByte '--- extension type
pvSkipBlock
Case ucsGblTrailer
m_bEOF = True
Exit Do
Case 0
Case Else
Err.Raise vbObjectError + 1, , ERR_UNEXPECTED_BLOCK
End Select
Loop
End If
'--- success
MoveLast = True
Exit Function
EH:
RaiseError FUNC_NAME
End Function
'= private ===============================================================
Private Function pvGetFlag(ByVal lFlags As Long, ByVal lMask As UcsGifFlags) As Long
If lMask > 0 Then
pvGetFlag = (lFlags And lMask)
Do While (lMask And 1) = 0
lMask = lMask \ 2
pvGetFlag = pvGetFlag \ 2
Loop
End If
End Function
Private Function pvPadScanline(ByVal lOffset As Long)
'--- DIB section horizontal scanline padding to dword
pvPadScanline = (lOffset + 3) And (Not 3)
End Function
'= I/O handling ==========================================================
Private Function pvReadByte() As Byte
Const FUNC_NAME As String = "pvReadByte"
On Error GoTo EH
If VBA.EOF(m_nFile) Then
Err.Raise vbObjectError + 4, , ERR_INPUT_PAST_EOF
End If
Get #m_nFile, , pvReadByte
Exit Function
EH:
RaiseError FUNC_NAME
End Function
道素 2003-07-15
- 打赏
- 举报
给你一个操作gif得模块
'=========================================================================
'
' VB Gif Library Project
' Copyright (c) 2003 Vlad Vissoultchev
'
' GIF87a/89a reader. Implements an LZW decoder. Warning! use of this
' code in commercial applications may fall under patent claims
' from Unisys which are holding patents on LZW algorithm.
'
'=========================================================================
Option Explicit
Private Const MODULE_NAME As String = "cGifReader"
'=========================================================================
' Events
'=========================================================================
Event Progress(ByVal CurrentLine As Long)
Event ImageComplete()
'=========================================================================
' API
'=========================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
'=========================================================================
' Constants and member variables
'=========================================================================
Private Const ERR_INVALID_GIF_FILE As String = "Invalid GIF file"
Private Const ERR_UNEXPECTED_BLOCK As String = "Unexpected image block"
Private Const ERR_PAST_END_OF_STACK As String = "Past end of stack (stacksize=4000)"
Private Const ERR_INVALID_LZW_CODE As String = "Invalid LZW code encountered"
Private Const ERR_INPUT_PAST_EOF As String = "Input past end of file"
Private Const STR_GIF87A As String = "GIF87a"
Private Const STR_GIF89A As String = "GIF89a"
Private Const MAX_BITS As Long = 12
Private Const TABLE_SIZE As Long = 2 ^ MAX_BITS
'--- look-up table 'powers-of-two'
Private m_aPOT(-1 To 31) As Long
'--- GIF file
Private m_nFile As Integer
Private m_sFileName As String
Private m_lFirstFrameLoc As Long
Private m_bEOF As Boolean
'--- for GIF content
Private m_uHeader As UcsGifHeader
Private m_uImageDesc As UcsGifImageDescriptor
Private m_uGraphicControl As UcsGifGraphicControl
Private m_lFrameIndex As Long
'--- for current frame buffers
Private m_aImageBits() As Byte
Private m_aGlobalLut(0 To 767) As Byte '--- 767 = 3 * 256 - 1
Private m_aImageLut(0 To 767) As Byte
'--- for LZW decoder
Private m_lInitBits As Long
Private m_lClearTable As Long
Private m_lInputBitCount As Long
Private m_lInputBitBuffer As Long
Private m_lCurrentBits As Long
Private m_lMaxCode As Long
Private m_lSubBlockSize As Long
Private m_aPrefixCode(0 To TABLE_SIZE) As Long
Private m_aAppendChar(0 To TABLE_SIZE) As Byte
Private Type UcsGifHeader
aSigVersion(0 To 5) As Byte
nScreenWidth As Integer
nScreenHeight As Integer
bFlags As Byte
bBackgroungColor As Byte
bAspectRatio As Byte
End Type
Private Type UcsGifImageDescriptor
nImageLeft As Integer
nImageTop As Integer
nImageWidth As Integer
nImageHeight As Integer
bFlags As Byte
End Type
Private Type UcsGifGraphicControl
cbSize As Byte
bFlags As Byte
nDelayTime As Integer
bTransparentColor As Byte
bTerminator As Byte
End Type
Private Enum UcsGifFlags
'--- for header flags
ucsGflGlobalLut = &H80
ucsGflColorResolution = &H70
ucsGflGlobalLutSorted = &H4
ucsGflGlobalLutSize = &H7
'--- for image descriptor flags
ucsGflLocalLut = &H80
ucsGflInterlace = &H40
ucsGflLocalLutSorted = &H20
ucsGflLocalLutSize = &H7
'--- for graphics control
ucsGflDisposalMethod = &H1C
ucsGflUserInput = &H2
ucsGflTransparentColor = &H1
End Enum
Private Enum UcsGifFileBlock
ucsGblImageBlock = &H2C '--- ","
ucsGblExtension = &H21 '--- "!"
ucsGblTrailer = &H3B '--- ";"
End Enum
Private Enum UcsGifExtensionType
ucsGexGraphicsControl = &HF9 '--- transparency etc. extension
End Enum
Public Enum UcsGifDisposalMethod
ucsDsmNotSpecified
ucsDsmDontDispose
ucsDsmRestoreBackground
ucsDsmRestorePrevious
End Enum
'=========================================================================
' Error management
'=========================================================================
Private Sub RaiseError(sFunction As String)
With Err
.Raise .Number, MODULE_NAME & "." & sFunction & IIf(Erl <> 0, "(" & Erl & ")", "") & vbCrLf _
& .Source, .Description, .HelpFile, .HelpContext
End With
End Sub
Private Sub PrintError(sFunction As String)
Debug.Print MODULE_NAME; "."; sFunction; IIf(Erl <> 0, "(" & Erl & ")", ""); ": "; Err.Description
End Sub
'=========================================================================
' Properties
'=========================================================================
Property Get FileName() As String
FileName = m_sFileName
End Property
Property Get SigVersion() As String
SigVersion = StrConv(m_uHeader.aSigVersion, vbUnicode)
End Property
Property Get HasGlobalLut() As Boolean
HasGlobalLut = (pvGetFlag(m_uHeader.bFlags, ucsGflGlobalLut) <> 0)
End Property
Property Get ScreenWidth() As Long
ScreenWidth = m_uHeader.nScreenWidth
End Property
Property Get ScreenHeight() As Long
ScreenHeight = m_uHeader.nScreenHeight
End Property
Property Get BackgroundColor() As Long
BackgroundColor = RGB(m_aImageLut(3 * m_uHeader.bBackgroungColor), _
m_aImageLut(3 * m_uHeader.bBackgroungColor + 1), _
m_aImageLut(3 * m_uHeader.bBackgroungColor + 2))
End Property
Property Get BackgroundIndex() As Long
BackgroundIndex = m_uHeader.bBackgroungColor
End Property
Property Get GlobalLutSize() As Long
GlobalLutSize = m_aPOT(1 + pvGetFlag(m_uHeader.bFlags, ucsGflGlobalLutSize))
End Property
Property Get IsInterlaced() As Boolean
IsInterlaced = (pvGetFlag(m_uImageDesc.bFlags, ucsGflInterlace) <> 0)
End Property
Property Get HasLocalLut() As Boolean
HasLocalLut = (pvGetFlag(m_uImageDesc.bFlags, ucsGflLocalLut) <> 0)
End Property
Property Get LocalLutSize() As Long
LocalLutSize = m_aPOT(1 + pvGetFlag(m_uImageDesc.bFlags, ucsGflLocalLutSize))
End Property
Property Get ImageLeft() As Long
ImageLeft = m_uImageDesc.nImageLeft
End Property
Property Get ImageTop() As Long
ImageTop = m_uImageDesc.nImageTop
End Property
Property Get ImageWidth() As Long
ImageWidth = m_uImageDesc.nImageWidth
End Property
Property Get ImageHeight() As Long
ImageHeight = m_uImageDesc.nImageHeight
End Property
Property Get IsTransparent() As Boolean
IsTransparent = (pvGetFlag(m_uGraphicControl.bFlags, ucsGflTransparentColor) <> 0)
End Property
Property Get TransparentColor() As Long
TransparentColor = RGB(m_aImageLut(3 * m_uGraphicControl.bTransparentColor), _
m_aImageLut(3 * m_uGraphicControl.bTransparentColor + 1), _
m_aImageLut(3 * m_uGraphicControl.bTransparentColor + 2))
End Property
Property Get TransparentIndex() As Long
TransparentIndex = m_uGraphicControl.bTransparentColor
End Property
'=========================================================================
'
' VB Gif Library Project
' Copyright (c) 2003 Vlad Vissoultchev
'
' GIF87a/89a reader. Implements an LZW decoder. Warning! use of this
' code in commercial applications may fall under patent claims
' from Unisys which are holding patents on LZW algorithm.
'
'=========================================================================
Option Explicit
Private Const MODULE_NAME As String = "cGifReader"
'=========================================================================
' Events
'=========================================================================
Event Progress(ByVal CurrentLine As Long)
Event ImageComplete()
'=========================================================================
' API
'=========================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
'=========================================================================
' Constants and member variables
'=========================================================================
Private Const ERR_INVALID_GIF_FILE As String = "Invalid GIF file"
Private Const ERR_UNEXPECTED_BLOCK As String = "Unexpected image block"
Private Const ERR_PAST_END_OF_STACK As String = "Past end of stack (stacksize=4000)"
Private Const ERR_INVALID_LZW_CODE As String = "Invalid LZW code encountered"
Private Const ERR_INPUT_PAST_EOF As String = "Input past end of file"
Private Const STR_GIF87A As String = "GIF87a"
Private Const STR_GIF89A As String = "GIF89a"
Private Const MAX_BITS As Long = 12
Private Const TABLE_SIZE As Long = 2 ^ MAX_BITS
'--- look-up table 'powers-of-two'
Private m_aPOT(-1 To 31) As Long
'--- GIF file
Private m_nFile As Integer
Private m_sFileName As String
Private m_lFirstFrameLoc As Long
Private m_bEOF As Boolean
'--- for GIF content
Private m_uHeader As UcsGifHeader
Private m_uImageDesc As UcsGifImageDescriptor
Private m_uGraphicControl As UcsGifGraphicControl
Private m_lFrameIndex As Long
'--- for current frame buffers
Private m_aImageBits() As Byte
Private m_aGlobalLut(0 To 767) As Byte '--- 767 = 3 * 256 - 1
Private m_aImageLut(0 To 767) As Byte
'--- for LZW decoder
Private m_lInitBits As Long
Private m_lClearTable As Long
Private m_lInputBitCount As Long
Private m_lInputBitBuffer As Long
Private m_lCurrentBits As Long
Private m_lMaxCode As Long
Private m_lSubBlockSize As Long
Private m_aPrefixCode(0 To TABLE_SIZE) As Long
Private m_aAppendChar(0 To TABLE_SIZE) As Byte
Private Type UcsGifHeader
aSigVersion(0 To 5) As Byte
nScreenWidth As Integer
nScreenHeight As Integer
bFlags As Byte
bBackgroungColor As Byte
bAspectRatio As Byte
End Type
Private Type UcsGifImageDescriptor
nImageLeft As Integer
nImageTop As Integer
nImageWidth As Integer
nImageHeight As Integer
bFlags As Byte
End Type
Private Type UcsGifGraphicControl
cbSize As Byte
bFlags As Byte
nDelayTime As Integer
bTransparentColor As Byte
bTerminator As Byte
End Type
Private Enum UcsGifFlags
'--- for header flags
ucsGflGlobalLut = &H80
ucsGflColorResolution = &H70
ucsGflGlobalLutSorted = &H4
ucsGflGlobalLutSize = &H7
'--- for image descriptor flags
ucsGflLocalLut = &H80
ucsGflInterlace = &H40
ucsGflLocalLutSorted = &H20
ucsGflLocalLutSize = &H7
'--- for graphics control
ucsGflDisposalMethod = &H1C
ucsGflUserInput = &H2
ucsGflTransparentColor = &H1
End Enum
Private Enum UcsGifFileBlock
ucsGblImageBlock = &H2C '--- ","
ucsGblExtension = &H21 '--- "!"
ucsGblTrailer = &H3B '--- ";"
End Enum
Private Enum UcsGifExtensionType
ucsGexGraphicsControl = &HF9 '--- transparency etc. extension
End Enum
Public Enum UcsGifDisposalMethod
ucsDsmNotSpecified
ucsDsmDontDispose
ucsDsmRestoreBackground
ucsDsmRestorePrevious
End Enum
'=========================================================================
' Error management
'=========================================================================
Private Sub RaiseError(sFunction As String)
With Err
.Raise .Number, MODULE_NAME & "." & sFunction & IIf(Erl <> 0, "(" & Erl & ")", "") & vbCrLf _
& .Source, .Description, .HelpFile, .HelpContext
End With
End Sub
Private Sub PrintError(sFunction As String)
Debug.Print MODULE_NAME; "."; sFunction; IIf(Erl <> 0, "(" & Erl & ")", ""); ": "; Err.Description
End Sub
'=========================================================================
' Properties
'=========================================================================
Property Get FileName() As String
FileName = m_sFileName
End Property
Property Get SigVersion() As String
SigVersion = StrConv(m_uHeader.aSigVersion, vbUnicode)
End Property
Property Get HasGlobalLut() As Boolean
HasGlobalLut = (pvGetFlag(m_uHeader.bFlags, ucsGflGlobalLut) <> 0)
End Property
Property Get ScreenWidth() As Long
ScreenWidth = m_uHeader.nScreenWidth
End Property
Property Get ScreenHeight() As Long
ScreenHeight = m_uHeader.nScreenHeight
End Property
Property Get BackgroundColor() As Long
BackgroundColor = RGB(m_aImageLut(3 * m_uHeader.bBackgroungColor), _
m_aImageLut(3 * m_uHeader.bBackgroungColor + 1), _
m_aImageLut(3 * m_uHeader.bBackgroungColor + 2))
End Property
Property Get BackgroundIndex() As Long
BackgroundIndex = m_uHeader.bBackgroungColor
End Property
Property Get GlobalLutSize() As Long
GlobalLutSize = m_aPOT(1 + pvGetFlag(m_uHeader.bFlags, ucsGflGlobalLutSize))
End Property
Property Get IsInterlaced() As Boolean
IsInterlaced = (pvGetFlag(m_uImageDesc.bFlags, ucsGflInterlace) <> 0)
End Property
Property Get HasLocalLut() As Boolean
HasLocalLut = (pvGetFlag(m_uImageDesc.bFlags, ucsGflLocalLut) <> 0)
End Property
Property Get LocalLutSize() As Long
LocalLutSize = m_aPOT(1 + pvGetFlag(m_uImageDesc.bFlags, ucsGflLocalLutSize))
End Property
Property Get ImageLeft() As Long
ImageLeft = m_uImageDesc.nImageLeft
End Property
Property Get ImageTop() As Long
ImageTop = m_uImageDesc.nImageTop
End Property
Property Get ImageWidth() As Long
ImageWidth = m_uImageDesc.nImageWidth
End Property
Property Get ImageHeight() As Long
ImageHeight = m_uImageDesc.nImageHeight
End Property
Property Get IsTransparent() As Boolean
IsTransparent = (pvGetFlag(m_uGraphicControl.bFlags, ucsGflTransparentColor) <> 0)
End Property
Property Get TransparentColor() As Long
TransparentColor = RGB(m_aImageLut(3 * m_uGraphicControl.bTransparentColor), _
m_aImageLut(3 * m_uGraphicControl.bTransparentColor + 1), _
m_aImageLut(3 * m_uGraphicControl.bTransparentColor + 2))
End Property
Property Get TransparentIndex() As Long
TransparentIndex = m_uGraphicControl.bTransparentColor
End Property
lihonggen0 2003-07-14
- 打赏
- 举报
在VB6.0中播放GIF动画
摘 要： 由 于GIF 格 式 动 画 文 件 具 有 小 巧、 制作 方 便 等 特 点，因 此 在 网 上 得 到 广 泛 应 用，但 遗 憾 的 是VB 中 的 多 媒 体 控 件 却 无 法 播 放 它， 这 给 我 们 设 计VB 应 用 程 序 带 来 了 不 便。 在此 我 们 向 大 写 介 绍 一 种 利 用 网 络 浏 览 器IE 实现 在VB 中 播 放GIF 动 画 的 方 法。 并 给 出 一 个 简捷、 实 用 的“ 画 中 画” 滚 动 显 示 程 序。
---- GIF 动 画 格 式 文 件 是 一 种 动 态 存 储 的 图 形格 式 文 件。 在 内 容 相 同 的 条 件 下， 与 其 它 格式 文 件 相 比， 由 于 它 占 用 的 存 储 空 间 少， 且制 作 手 段 成 熟， 可 浏 览 的 软 件 工 具 也 很 多，所 以 倍 受 设 计 者 的 青 睐。 然 而 令 人 遗 憾 的 是， 在Visual Basic 中， 无 论 是 多 媒 体 控 件MCI、MCIWnd， 还 是Animation 控 件, 甚 至 调 用
Windows API 函数 都 无 法 播 放GIF 格 式 的 动 画 文 件。 造 成 这 一现 象 的 原 因 在 于GIF 动 画 格 式 文 件 不 是VB 多 媒体 控 件 所 支 持 的 视 频 格 式 文 件（VB 多 媒 体 控件 所 支 持 的 视 频 格 式 文 件 主 要 有：AVI 格 式、MOV 格 式、FLI 格 式、FLC 格 式 等）。 以 往 我 们 的 解决 方 法 是： 首 先 利 用 一 些 格 式 转 换 工 具， 比如GIF Movie Gear 将GIF 格
式 的 动 画 文 件 转 换 为AVI格 式 的 动 画 文 件， 然 后 再 用 多 媒 体 控 件MCI和MCIWnd 进 行 播 放。 但 这 种 做 法 主 要 存 在 以 下两 个 缺 陷：
---- 1 ． 所 形 成 的AVI 格 式 动 画 文 件 太 大（ 常 常是GIF 格 式 文 件的 几 十 倍）， 从 而 影 响 系 统 的效 率。
---- 2 ． 所 形 成 的AVI 格 式 动 画 文 件 往 往 带 有比 较 复 杂 的 调 色 板 信 息， 所 以 当 程 序 在 播 放这 种AVI 格 式 动 画 文 件 时， 如 果 还 兼 有 动 态 显示 的 文 字 和 图 象 信 息， 则 整 个 画 面 就 会 产 生抖 动 和 闪 烁， 从 而 使 显 示 效 果 大 受 影 响。
---- 为 解 决 这 个 问 题， 我 们 在 此 提 出 一 个 全新 的 处 理 方 案 : 通 过 在VB 中 调 用IE 浏 览器 来 实 现GIF 动 画 的 播 放， 实 际 使 用 表 明： 效果 甚 好。
---- 一、 浏 览 器IE 和WebBrowser 控 件
---- 众 所 周 知， 运 行VB6.0 需 要 安 装 浏 览 器IE4.0或 以 上 版 本， 当IE4.0 和VB6.0 安 装 完 成 后， 我 们便 可 以 在VB6.0 中 使 用IE 所 提 供 的WebBrowser 控 件播 放GIF 动 画 了。 具 体 方 法 如 下：
---- 1 ． 由 于WebBrowser 控 件 并 不 是VB 的 基 本 控件， 因 此 在 使 用 该 控 件 之 前 必 须 先 将 其 装 入工 具 箱 中。 装 入 方 法： 在 工 具 箱 中 点 击 鼠 标右 键 → 选 中“ 部 件” → 复 选Microsoft InternetControls → 然 后 点 击“ 确 定” 键 即 可。
---- 2 ． 选 取WebBrowser 控 件（ 注 意 不 同 版 本IE的WebBrowser 控 件 的 图 标 是 不 同 的，IE4.0 中的WebBrowser 控 件 的 图 标 是 一 个 地 球；IE3.0 是 一个 搜 索 图 标。）， 添 加 到 窗 体 的 相 应 位 置 上。
---- 3 ． 设 计 相 应 代 码， 通 过 使 用WebBrowser 控件 的Navigate 方 法 播 放GIF 动 画 文 件。
---- Navigate 方 法 的 语 法 格 式 为：
WebBrowser 控 件 名.Navigate URL [Flags,][TargetFrameName,][PostData,][Headers]
---- WebBrowser 控 件 支 持 的 主 要 方 法 有:
GoBack — — — 回 退 到 上 一 屏。
GoForward — — — 进 入 到 下 一 屏。
GoHome — — — 回 家。 即 回 到 主 页。
Stop — — — 停 止 导 航。
Refresh — — — 刷 新。
Navigate — — — 导 航。
---- WebBrowser 控 件 所 响 应 的 事 件:
---- BeforeNavigate 事 件 — — — 在 开 始 导 航 前 发 生。 一 般 在 此 获 取 完 整 的URL 字 符 串。
---- WebBrowser 控 件 最 主 要 的 参 数:
---- URL — — — 获 得 导 航 用 的 标 准URL 字 符 串。例 如： 它 能 将”www.MicroSoft.Com” 自 动 翻 译 为” http:// www.MicroSoft.Com”.URL 是Uniform Resource Locator 的 缩 写， 是 在Internet 的WWW 服 务 程 序 上 用 于 指 定 信 息 位 置 的 表 示 方 法。
---- 下 面 我 们 结 合 一 个 实 例 进 行 具 体 说 明。这 是 一 个“ 画 中 画” 滚 动 显 示 应 用 程 序， 界 面 由 循 环 滚 动 显 示 的 文 字、 背 景 图 象、 和 播 放 的GIF 动 画 三 部 分 组 成。 其 中 循 环 显 示 的 文 字 用 透 明 的Label 控 件 实 现； 动 画 用WebBrowser 控 件 实 现 播 放。
---- ① 所 需 控 件：
---- 本 程 序 需 要 一 个PictureBox 控 件、 一 个Label 控 件、 一 个WebBrowser 控 件、 一 个Timer 控 件。
---- ② 各 控 件 的 属 性 设 置 如 下：
控件名称 属性 设置值 含 义
Label1控件 BackStyle 0 设置Label1控件的背景是透明的。
Timer1控件 Interval 200 设置每0.2秒发生一次Timer1_Timer()事件。
---- ③ 各 事 件 的 相 应 代 码 如 下：
首 先 定 义 一 个 变 量， 以 便 用 它 来 存 放 需 要 滚 动 显 示 的 字 符 串。
Dim aa As String
在Form_Load() 事 件 中 进 行 初 始 化 工 作， 具 体 代 码 如 下：
Private Sub Form_Load()
Picture1.Picture = LoadPicture(App.Path & "\demo1.jpg")
WebBrowser1.Navigate (App.Path & "\new1.gif")
---- aa = " 这 是 一 个 利 用 网 络 浏 览 器IE 中WebBrowser 控 件 制 作 的GIF 动 画 播 放 程 序。 "
Label1.ForeColor = QBColor(11)
Label1.FontSize = 18
Label1.Caption = aa
End Sub
◆ 在Timer1_Timer()事件中，每隔0.2秒改变
一次Label1控件的Caption属性值。
Private Sub Timer1_Timer()
` 让字符串头尾相接，以便形成滚动效果。
aa = Mid(aa, 2, 59) + Mid(aa, 1)
Label1.Caption = aa
End Sub
◆ 在Picture1_Click()事件中，卸载并退出应用程序。
Private Sub Picture1_Click()
Unload Me
End Sub
---- ④ 调 整 各 控 件 至 适 当 的 大 小 和 位 置。
---- 二、 注 意 事 项 及 附 加 说 明
---- 1 ． 不 同 版 本IE 的Microsoft Internet Controls 所 包 含 的 控 件 及 控 件 数 量 是 不 同 的。 设 计 者 在 使 用 时 必 须 注 意 这 一 点。
---- ① WINDOWS95 所 带 的IE3.0 的Microsoft Internet Controls 只 包 含 一 个 控 件， 即WebBrowser 控 件。
---- ② 中 文 版IE4.0CN 的Microsoft Internet Controls 包 含 两 个 控 件， 即WebBrowser 控 件 和DownUp 控 件。
---- ③ 英 文 版IE4.01 的Microsoft Internet Controls 包含 两 个 控 件， 即WebBrowser 控 件 和ShellFolderViewOC控 件。
---- 2 ． 实 际 上， 在VB5.0 中 也 可 以 使 用WebBrowser控 件 播 放GIF 动 画， 但 如 果VB5.0 是 安 装在WINDOWS95 下， 那 么 必 须 安 装IE3.0 或IE4.0； 如 果是 安 装 在WINDOWS98 下， 则 可 不 必（ 因 为WINDOWS98自 带IE4.0）。 然 而 需 要 特 别 声 明 的 是： 无 论 是VB5.0 的 联 机 手 册， 还 是 其 它 帮 助 文 件， 均 未介 绍 有 关WebBrowser 控 件 的 资 料（ 因 为WebBrowser控 件 不 是Visual Basic 的 控 件， 而 是 由IE 提 供 的。）。 读 者 如 要 详 细 了 解 这 方 面 的 情 况， 请 查阅Visual Studio 98 中 的MSDN。 具 体 步 骤 如 下：
---- 从Microsoft Developer Network 中 选 择MSDN LibraryVisual Studio 6.0, 查 找 关 于Reusing the WebBrowserControl 的 主 题， 位 置 在Internet Explorer:PlatfromSDK。 从 哪 可 以 找 到 有 关WebBrowser 控 件 的 详 尽资 料。
---- 3 ． 注 意 你 的 发 布 权 限。 由 于 受 到 软 件 知识 产 权 的 影 响， 任 何 软 件 都 有 它 的 发 行 权 限。 在Visual Basic 中, 你 可 以 自 由 地 发 布 任 何由Visual Basic 创 建 的 应 用 程 序、 部 件、DLL、Active X 控 件、 各 种 媒 体 文 件、 示 例 应 用 程 序 在\Samples 子 目 录 下） 以 及 系 统 第 一 次 安 装Visual Basic 时 最 初 复 制 到Visual Basic 主 目 录的\Icons 子 目 录、\Graphics 子 目 录、\ODBC 子 目 录下 的 任 何 文 件。 但 除 此 之 外 的 其 它 软 件 一 般都 不 允 许 你 发 布。 例 如： 你 的 应 用 程 序 中 包含 有 对 网 络 浏 览 器IE 的 引 用， 那 么“ 应 用 程 序 安 装 向 导” 在 创 建 你
的 安 装 程 序 时， 就 会 因试 图 发 布 无 权 发 布 的 软 件 而 出 错。
---- 错 误 原 因： 因 为 我 们 无 权 用Visual Basic 的“应 用 程 序 安 装 向 导” 来 发 布 网 络 浏 览 器IE。
---- 那 么 既 然 我 们 不 能 在VB 的 应 用 程 序 中 发布 网 络 浏 览 器IE， 又 怎 么 样 保 证 应 用 程 序 中的 引 用 能 得 以 实 现 呢 ？
---- 解 决 办 法 ①： 如 果 用 户 的 计 算 机 上 已 经安 装 了 网 络 浏 览 器IE， 那 么 直 接 安 装 你 开 发的 应 用 程 序 即 可。
---- 解 决 办 法 ②： 如 果 用 户 的 计 算 机 上 还 未安 装 网 络 浏 览 器IE， 那 么 只 要 在 运 行 你 的 应用 程 序 之 前， 安 装 上 网 络 浏 览 器IE 即 可。
---- 需 要 说 明 的 是， 上 述 解 决 方 法 具 有 普 遍性， 如 果 你 的 应 用 程 序 在 发 布 时 遇 到 类 似 的问 题（ 例 如： 你 的 应 用 程 序 中 包 含 有 对Word97、Excel 97 的 引 用）， 均 可 照 此 处 理。
lxcc 2003-07-14
- 打赏
- 举报
网上有现成的gif控件，找找，免费的不多
