GDI+分解gif动画

lss001

Private Declare Function GdipImageGetFrameCount Lib "gdiplus" (ByVal image As Long, _
    dimensionID As Guid, Count As Long) As GpStatus
Private Declare Function GdipImageSelectActiveFrame Lib "gdiplus" (ByVal image As Long, _
    dimensionID As Guid, ByVal frameIndex As Long) As GpStatus
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf _
    As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, _
    ByVal FileName As Long, guidEncoder As Guid, encoderParams As Any) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As String, image As Long) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, Graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As GpStatus

Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As Guid) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Type Guid
    Data1   As Long
    Data2   As Integer
    Data3   As Integer
    Data4(7)   As Byte
End Type
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Enum GpStatus ' aka Status
   OK = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTruePrivateTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
End Enum

Private Sub GDI分解gif图像()
    Dim hImage&, fCount&, hwnd&, appHDC&, i&, gGuid As Guid, bGuid As Guid
    Dim uInput As GDIPlusStartupInput, Graphics&, token&
    Const PropertyTagFrameDelay = &H5100

    uInput.GdiPlusVersion = 1
    GdiplusStartup token, uInput '开始/初始化
    hwnd = Application.hwnd
    appHDC = GetDC(hwnd) '获取DC//句柄

    GdipCreateFromHDC appHDC, Graphics
    '根据实际修改以下文件路径/文件名
    GdipLoadImageFromFile VBA.StrConv(ThisWorkbook.Path & "\xxx.gif", 64), hImage
    CLSIDFromString StrPtr("{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"), gGuid 'gif
    CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), bGuid 'bmp
    GdipImageGetFrameCount hImage, gGuid, fCount '帧数
    If fCount > 0 Then
        For i = 1 To fCount
            GdipImageSelectActiveFrame hImage, gGuid, i '选择当前帧
            GdipSaveImageToFile hImage, StrPtr("d:\" & i & ".bmp"), bGuid, ByVal 0& '保存
        Next
    End If

    GdipDisposeImage hImage
    GdipDeleteGraphics Graphics
    GdiplusShutdown token '结束/释放gdi+
    ReleaseDC hwnd, appHDC '释放appHdc
End Sub

morpheus126

求64位可用版本，谢谢大神

perfect131

morpheus126 发表于 2023-11-14 19:57
求64位可用版本，谢谢大神

https://club.excelhome.net/thread-1676897-1-1.html

小fisher

morpheus126 发表于 2023-11-14 19:57
求64位可用版本，谢谢大神

改一下函数和变量声明就行了，直接改成64位的了，没有兼容32位

1. Private Declare PtrSafe Function GdipImageGetFrameCount Lib "gdiplus" (ByVal image As LongPtr, _
   
2.     dimensionID As Guid, Count As Long) As GpStatus
   
3. Private Declare PtrSafe Function GdipImageSelectActiveFrame Lib "gdiplus" (ByVal image As LongPtr, _
   
4.     dimensionID As Guid, ByVal frameIndex As Long) As GpStatus
   
5. Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf _
   
6.     As GDIPlusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As GpStatus
   
7. Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As LongPtr, _
   
8.     ByVal FileName As LongPtr, guidEncoder As Guid, encoderParams As Any) As GpStatus
   
9. Private Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As String, image As LongPtr) As GpStatus
   
10. Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As GpStatus
    
11. Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As GpStatus
    
12. Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As LongPtr, Graphics As LongPtr) As GpStatus
    
13. Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As LongPtr) As GpStatus
    
14. 
    
15. Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal Str As LongPtr, id As Guid) As Long
    
16. Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As Long
    
17. Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    
18. 
    
19. Private Type Guid
    
20.     Data1   As Long
    
21.     Data2   As Integer
    
22.     Data3   As Integer
    
23.     Data4(7)   As Byte
    
24. End Type
    
25. Private Type GDIPlusStartupInput
    
26.     GdiPlusVersion As Long
    
27.     DebugEventCallback As LongPtr
    
28.     SuppressBackgroundThread As Long
    
29.     SuppressExternalCodecs As Long
    
30. End Type
    
31. Private Enum GpStatus ' aka Status
    
32.    OK = 0
    
33.    GenericError = 1
    
34.    InvalidParameter = 2
    
35.    OutOfMemory = 3
    
36.    ObjectBusy = 4
    
37.    InsufficientBuffer = 5
    
38.    NotImplemented = 6
    
39.    Win32Error = 7
    
40.    WrongState = 8
    
41.    Aborted = 9
    
42.    FileNotFound = 10
    
43.    ValueOverflow = 11
    
44.    AccessDenied = 12
    
45.    UnknownImageFormat = 13
    
46.    FontFamilyNotFound = 14
    
47.    FontStyleNotFound = 15
    
48.    NotTruePrivateTypeFont = 16
    
49.    UnsupportedGdiplusVersion = 17
    
50.    GdiplusNotInitialized = 18
    
51.    PropertyNotFound = 19
    
52.    PropertyNotSupported = 20
    
53. End Enum
    
54. 
    
55. Private Sub GDI分解gif图像()
    
56.     Dim hImage As LongPtr, fCount&, hwnd As LongPtr, appHDC As LongPtr, i&, gGuid As Guid, bGuid As Guid
    
57.     Dim uInput As GDIPlusStartupInput, Graphics As LongPtr, token As LongPtr
    
58.     Const PropertyTagFrameDelay = &H5100
    
59. 
    
60.     uInput.GdiPlusVersion = 1
    
61.     GdiplusStartup token, uInput  '开始/初始化
    
62.     hwnd = Application.hwnd
    
63.     appHDC = GetDC(hwnd) '获取DC//句柄
    
64. 
    
65.     GdipCreateFromHDC appHDC, Graphics
    
66.     '根据实际修改以下文件路径/文件名
    
67.     GdipLoadImageFromFile VBA.StrConv("d:\edge.gif", 64), hImage
    
68.     CLSIDFromString StrPtr("{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"), gGuid 'gif
    
69.     CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), bGuid 'bmp
    
70.     GdipImageGetFrameCount hImage, gGuid, fCount '帧数
    
71.     If fCount > 0 Then
    
72.         For i = 1 To fCount
    
73.             GdipImageSelectActiveFrame hImage, gGuid, i '选择当前帧
    
74.             GdipSaveImageToFile hImage, StrPtr("d:" & i & ".bmp"), bGuid, ByVal 0&  '保存
    
75.         Next
    
76.     End If
    
77. 
    
78.     GdipDisposeImage hImage
    
79.     GdipDeleteGraphics Graphics
    
80.     GdiplusShutdown token '结束/释放gdi+
    
81.     ReleaseDC hwnd, appHDC '释放appHdc
    
82. End Sub
    
83. 
    
84. 
    

复制代码

morpheus126

小fisher 发表于 2023-11-15 09:03
改一下函数和变量声明就行了，直接改成64位的了，没有兼容32位

谢谢大佬。。。我试过自己改，还是没改彻底，主要是数据类型部分失踪不得敲门

morpheus126

perfect131 发表于 2023-11-14 21:38
https://club.excelhome.net/thread-1676897-1-1.html

谢谢大佬，您的我也抄了

dongdonggege

两年前，我也曾尝试过，合成，分解，播放gif，感谢分享。在此能遇到小fisher，能学习到很多。