clsloadpcx.cls

一个游戏的原代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "LoadPCX"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Autor: ALKO
'e-mail: [e-mail]

Option Explicit

Private Type RGBTriple
    Red As Byte
    Green As Byte
    Blue As Byte
End Type

Private Type PCXHeader
    Manufacturer As Byte  '10 = ZSoft
    Version As Byte 'Version
    Encoding As Byte    '1 = .PCX RLE
    Bpp As Byte    '1, 2, 4, 8
    XMIN As Integer
    YMIN As Integer
    XMAX As Integer
    YMAX As Integer
    HDpi As Integer
    VDpi As Integer
    ColourPalette(0 To 15) As RGBTriple
    Reserved1 As Byte
    Planes As Byte
    BytesPerLine As Integer
    PaletteInfo As Integer
    HScreenSize As Integer
    VScreenSize As Integer
    Reserved2(0 To 53) As Byte
End Type

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

'Variables
Private nLineSize As Long
Private BitmapData() As Byte

Private i As Long

Private nWidth As Long
Private nHeight As Long
Private Header As PCXHeader

Private cX As Long
Private cY As Long

Public Sub LoadPCX(ByVal FileName As String)
Dim nFreefile As Integer
nFreefile = FreeFile

Open FileName For Binary Lock Write As #nFreefile
    Get #nFreefile, , Header
Close #nFreefile

With Header
    nWidth = .XMAX - .XMIN + 1
    nHeight = .YMAX - .YMIN + 1
    nLineSize = .Planes * .BytesPerLine
End With

If Header.Bpp = 8 Then
    If Header.Planes = 1 Then
        Read8Bit FileName
    End If
End If
End Sub

Private Sub Read8Bit(ByRef FileName As String)
'Variables and arrays
Dim nFreefile As Integer
Dim Header As PCXHeader
Dim Palette8(0 To 255) As RGBTriple
Dim PalByte As Byte
Dim result As Long
Dim 躡ergabe() As Byte
Const cStartOfPalette As Long = 12

nFreefile = FreeFile
'Open File
Open FileName For Binary Lock Write As #nFreefile
    'Read the header
    Get #nFreefile, , Header
    'Get data
    ReDim BitmapData(LOF(nFreefile) - Len(Header))
    Get #nFreefile, , BitmapData()
    'Get palette indication byte
    Seek #nFreefile, LOF(nFreefile) - 768
    Get #nFreefile, , PalByte
    
    'Get Palette
    If PalByte = cStartOfPalette Then
        Seek #nFreefile, LOF(nFreefile) - 767
        Get #nFreefile, , Palette8()
    Else
        'Not correct.
        For i = 0 To 255
            Palette8(i).Blue = i
            Palette8(i).Green = i
            Palette8(i).Red = i
        Next i
    End If
Close #nFreefile

'==================================================
    
If Header.Encoding = 1 Then
    DecodePcx BitmapData
End If
    
MakeBitmap BitmapData, nHeight, nLineSize

Form1.Cls

For cY = 0 To (UBound(BitmapData) \ Header.BytesPerLine) - 1
    For cX = 1 To Header.BytesPerLine - 1
        i = UBound(BitmapData) - (Header.BytesPerLine - cX + cY * Header.BytesPerLine)
        Form1.ForeColor = RGB(Palette8(BitmapData(i)).Red, Palette8(BitmapData(i)).Green, Palette8(BitmapData(i)).Blue)
        Form1.PSet (cX, cY)
    Next cX
Next cY
End Sub


Private Sub DecodePcx(ImageArray() As Byte)
Dim RawData() As Byte
Dim Stand As Long
Dim i As Long
Dim x As Long
Dim n As Long
Dim c As Byte
Dim Length As Long

RawData = ImageArray

For Length = 0 To UBound(RawData) - 1
    x = RawData(Length)
    If x >= 192 Then
        n = x - 192
        c = RawData(Length + 1)
        Length = Length + 1
    Else
        n = 1
        c = x
    End If
    
    For i = 1 To n
        ReDim Preserve ImageArray(Stand)
        ImageArray(Stand) = c
        Stand = Stand + 1
    Next i
Next Length
End Sub

Private Sub MakeBitmap(ImageArray() As Byte, Lines As Long, BytesLine As Long)
Dim 躡ergabe() As Byte
Dim Gr鲞e As Long
Dim Gr鲞eBMP As Long
Dim i As Long
Dim Standort As Long
Dim nBitmapX As Long
    
If (BytesLine) Mod Len(nBitmapX) = 0 Then
    nBitmapX = BytesLine - 1
Else
    nBitmapX = (BytesLine \ 4) * 4 + 3
End If

Gr鲞e = Lines * BytesLine
Gr鲞eBMP = Lines * (nBitmapX + 1) - 1

ReDim 躡ergabe(UBound(ImageArray))
CopyMemory 躡ergabe(0), ImageArray(0), UBound(ImageArray) + 1

ReDim ImageArray(Gr鲞eBMP)
For i = 0 To BytesLine * Lines - BytesLine Step BytesLine
    CopyMemory ImageArray(Standort), 躡ergabe(Gr鲞e - i - BytesLine), BytesLine
    Standort = Standort + nBitmapX + 1
Next i
End Sub