module1.bas

自解Diablo II 的DC6图像文件格式（附自编文章）

Attribute VB_Name = "Module1"
Option Explicit

Public Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Public Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Public Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors(255) As RGBQUAD
End Type

Public Declare Function SetDIBitsToDevice Lib "gdi32.dll" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, ByVal dX As Long, ByVal dY As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Public Const BI_RGB As Long = 0&
Public Const DIB_RGB_COLORS As Long = 0
Public Const DIB_PAL_COLORS = 1

Public Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


'Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
'Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
'Public mInit As Boolean
'Public mFrequency As Currency
'Public Declare Function GetTickCount Lib "kernel32.dll" () As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long


Public Type DC6_Header_T
  Version As Long                 'DC6的版本，一般为&H00 00 00 06
  Unknown1 As Long                '一般为&H00 00 00 00
  Unknown2 As Long                '未知
  Termination(1 To 4) As Byte     '一般为&HEE EE EE EE 或 &HCD CD CD CD
  Directions As Long              '帧集合数目
  Frames_Per_Dir As Long          '每个帧集合包含的帧数
  Frame_Index() As Long
End Type

Public Type DC6_Frame_Header_T
  Flip As Long                    '一个标志：为0时帧是由下向上显示的，
                                  '也就是帧的坐标零点在帧的左下角；
                                  '为1时帧是由下向上显示的，
                                  '也就是帧的坐标零点在帧的左上角。
  Frame_Width  As Long
  Frame_Height As Long
  Offset_X As Long
  Offset_Y As Long
  Unknown As Long
  Next_Block As Long              '下一帧在这个DC6的位置，也就是下一帧的开始指针
  Length As Long                  '这一帧出去帧头的图像数据所占大小
End Type

'Public Type Pal                   '暗黑II的调色板格式是BGR的，而不是RGB的！
'  B As Byte
'  G As Byte
'  R As Byte
'End Type

Public Type Play_State
  Play As Boolean
  Pause As Boolean
  Stop As Boolean
  Direction As Long
  Frame As Long
  Buffer As Byte
End Type

'Public Frame_Index() As Long      '这个DC6帧的索引指针表，大小为：
                                  'DC6_Header.Directions*DC6_Header.Frames_Per_Dir*4
'Public Pal(255) As RGBQUAD            'DiabloII的调色板

Public DeCompres_Dat() As Byte

Public Header As DC6_Header_T, Frame_Header() As DC6_Frame_Header_T

Public x1 As Long, y1 As Long
Public x2 As Long, y2 As Long
Public w As Long, h As Long


'public Const ImgWidth As Long = &H100
'public Const ImgHeight As Long = &H100

Public bi As BITMAPINFO
Public LineBytes As Long
Public MapData() As Byte 'MapData_1() As Byte, MapData_2() As Byte

Public Play_DC6 As Play_State


Public Sub DeCompres_DC6_Frame(File_Number As Long, _
                               Direction As Long)

  Dim i As Long, i2 As Long, Frm As Long
  Dim c As Byte, c2 As Byte
  Dim x As Long, Y As Long
  Dim x0 As Long, y0 As Long
  
  Dim LineIdx As Long ', CurIdx As Long

  For Frm = 0 To Header.Frames_Per_Dir - 1
    
    For i = 0 To bi.bmiHeader.biSizeImage
      
      DeCompres_Dat(Frm, i) = 190 'MapData_1(i) = 190  '
      
    Next i
  
    With Frame_Header(Direction * Header.Frames_Per_Dir + Frm)
    
      x0 = .Offset_X - x1
      y0 = h - 1 + .Offset_Y - y2
  
    End With
    
    x = x0
    Y = y0
  
    Seek #File_Number, Header.Frame_Index(Frm) + 33
  
    LineIdx = 0 'DIB是逆序存储的
  
    For i = 1 To Frame_Header(Frm).Length
  
      Get #File_Number, , c
    
      If c = &H80 Then
    
        Y = Y - 1
      
        LineIdx = (h - Y) * LineBytes
      
        x = x0
      
      Else
    
        If c And &H80 Then
      
          c2 = 0
          x = x + (c And &H7F)
          
        Else
          
          For i2 = 1 To c
            Get #File_Number, , c2
            i = i + 1
            DeCompres_Dat(Frm, LineIdx + x) = c2 'MapData_1(LineIdx + x) = c2 '
            x = x + 1
          Next i2
          
        End If
        
      End If
    
    Next i
  Next Frm
      
End Sub

Public Sub Load_Palette(PAL_FileName As String)
  Dim i As Long
  
  Open PAL_FileName For Binary As #1
  
  For i = 0 To 255
    
    With bi
      With .bmiColors(i)
        Get #1, , .rgbBlue
        Get #1, , .rgbGreen
        Get #1, , .rgbRed
        .rgbReserved = 0
      End With
    End With
    
  Next i
  
  Close #1
  
End Sub

Public Sub Load_DC6_File_Header(File_Number As Long)

  Dim i As Long
  
  
  Seek #File_Number, 1
  With Header
    Get #File_Number, , .Version
    Get #File_Number, , .Unknown1
    Get #File_Number, , .Unknown2
    
    For i = 1 To 4
    
      Get #File_Number, , .Termination(i)
      
    Next i
    
    Get #File_Number, , .Directions
    Get #File_Number, , .Frames_Per_Dir
    
    ReDim .Frame_Index(0 To .Directions * .Frames_Per_Dir - 1) As Long
    ReDim Frame_Header(0 To .Directions * .Frames_Per_Dir - 1) As DC6_Frame_Header_T
    
    For i = 0 To .Directions * .Frames_Per_Dir - 1
    
      Get #File_Number, , .Frame_Index(i)
    
    Next i
    
  End With
  
End Sub

Public Sub Load_DC6_Frame_Header(File_Number As Long)
  
  Dim i As Long
  
  For i = 0 To Header.Directions * Header.Frames_Per_Dir - 1
    
    Seek #File_Number, Header.Frame_Index(i) + 1
    
    With Frame_Header(i)
      Get #File_Number, , .Flip
      Get #File_Number, , .Frame_Width
      Get #File_Number, , .Frame_Height
      Get #File_Number, , .Offset_X
      Get #File_Number, , .Offset_Y
      Get #File_Number, , .Unknown
      Get #File_Number, , .Next_Block
      Get #File_Number, , .Length
    End With
  
  Next i
  
End Sub

Public Sub Find_Frame_Box()
  
  Dim i As Long
  
  x1 = y1 = 30000
  x2 = y2 = -300000
  
  For i = 0 To Header.Directions * Header.Frames_Per_Dir - 1
    
    With Frame_Header(i)
      
      If .Offset_X < x1 Then x1 = .Offset_X
      If .Offset_X + .Frame_Width > x2 Then x2 = .Offset_X + .Frame_Width
      If .Offset_Y - .Frame_Height < y1 Then y1 = .Offset_Y - .Frame_Height
      If .Offset_Y > y2 Then y2 = .Offset_Y
      
    End With
    
  Next i
    
  If x1 > 0 Then x1 = 0
  If x2 < 0 Then x2 = 0
  If y1 > 0 Then y1 = 0
  If y2 < 0 Then y2 = 0
  
  w = x2 - x1 + 2
  h = y2 - y1 + 2
  
  With bi
    With .bmiHeader
      .biSize = Len(bi.bmiHeader)
      .biWidth = w
      .biHeight = h
      .biBitCount = 8
      .biPlanes = 1
      .biCompression = BI_RGB
      .biClrUsed = 256
      .biClrImportant = 0
      LineBytes = ((.biWidth * .biBitCount + 31) And &HFFFFFFE0) \ 8
      .biSizeImage = LineBytes * .biHeight
      ReDim MapData(0 To .biSizeImage) 'MapData_1(0 To .biSizeImage), MapData_2(0 To .biSizeImage)
      ReDim DeCompres_Dat(0 To Header.Frames_Per_Dir - 1, 0 To .biSizeImage)
    End With
  End With
  
  
End Sub

Public Sub DisPlay_Frame(Picture As PictureBox) ', Frame As Long)
  
  Dim i As Long
  
  For i = 0 To bi.bmiHeader.biSizeImage
      
    MapData(i) = DeCompres_Dat(Play_DC6.Frame, i)
      
  Next i
    
  Call SetDIBitsToDevice(Picture.hDC, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, MapData(0), bi, DIB_RGB_COLORS)
    
End Sub

Public Sub Play_DC6_File(Picture As PictureBox)
  
  Dim i As Long, t As Single
  
  t = Timer

  
  Do
  
    
    'If Play_DC6.Play Then
    'Play_DC6.Buffer = Play_DC6.Buffer Xor 1
    '
    '  Select Case Play_DC6.Buffer
    '    Case 0
    '
    '      Call SetDIBitsToDevice(Picture.hDC, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, MapData_1(0), bi, DIB_RGB_COLORS)
    '
    '      Do: Loop Until (Timer - t >= 0.1)
    '
    '      t = Timer
    '
    '      For i = 0 To bi.bmiHeader.biSizeImage
    '
    '        MapData_2(i) = DeCompres_Dat(Play_DC6.Frame, i)
    '
    '      Next i
    '
    '    Case 1
    '
    '      Call SetDIBitsToDevice(Picture.hDC, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, MapData_2(0), bi, DIB_RGB_COLORS)
    '
    '      For i = 0 To bi.bmiHeader.biSizeImage
    '
    '        MapData_1(i) = DeCompres_Dat(Play_DC6.Frame, i)
    '
    '      Next i
    '
    '      Do: Loop Until (Timer - t >= 0.1)
    '
    '      t = Timer
    '
    '  End Select
    '
          Call SetDIBitsToDevice(Picture.hDC, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, MapData(0), bi, DIB_RGB_COLORS)
    
          For i = 0 To bi.bmiHeader.biSizeImage
    
            MapData(i) = DeCompres_Dat(Play_DC6.Frame, i)
    
          Next i
    
          Do: Loop Until (Timer - t >= 0.1)
    
          t = Timer

  Play_DC6.Frame = Play_DC6.Frame + 1
  If Play_DC6.Frame = Header.Frames_Per_Dir Then Play_DC6.Frame = 0
  
      
    'Else
    '
    '  For i = 0 To bi.bmiHeader.biSizeImage
    '
    '    MapData_1(i) = DeCompres_Dat(Play_DC6.Frame, i)
    '
    '  Next i
    '
    '  Call SetDIBitsToDevice(Picture.hDC, 0, 0, bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 0, 0, 0, bi.bmiHeader.biHeight, MapData_1(0), bi, DIB_RGB_COLORS)
    '
    'End If
    DoEvents
  Loop Until Play_DC6.Stop
  
  Play_DC6.Play = False
  
End Sub