Pcximage

Pcximage

Pcximage : Multi-millones de consejos para hacer su vida mas facil.

Importar / exportar PCX bajo Delphi (5.0)
////////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// ========= //
// //
// Finalizado: el 10 de agosto de 2001 //
// Autor: M. de Haan //
// Correo electronico: [email protected] //
// Prueba: bajo W95 SP1 //
// Version: 1.0 //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// Actualizacion: 14 de agosto de 2001 a la version 1.1 //
// Razon: Añadido de comprobacion de la version //
// comentario Añadido informacion sobre la version //
// Cambiado PCX encabezado de verificacion ID //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// Actualizacion: 19 de agosto de 2001 a la version 2.0 //
// Motivo: Advertencia de Delphi sobre el uso de metodos abstractos, //
// causado por la no aplicacion de TODAS TGraphic metodos //
// (Gracias a R. P. Sterkenburg para su diagnostico) //
// Añadido: SaveToClipboardFormat //
// LoadFromClipboardFormat //
// GetEmpty //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// Actualizacion: 13 de octubre de 2001 a la version 2.1 //
// Motivo: extraño errores, errores de lectura, EExternalException, IDE //
// colgante, Delphi colgantes, Depurador haning, windows //
// colgante, teclado bloqueado, y asi sucesivamente //
// Modificado: Asignar procedimiento //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// //
// El PCX formato de archivo de imagen es de autor: //
// ZSoft, PC Paintbrush, PC Paintbrush plus //
// Trademarks: NA //
// Realeza honorarios: NINGUNO //
// //
// El autor no se hace responsable por el uso de este software //
// //
// problemas Conocidos //
// & & & & & & //
// 1. Solo probado con PCX imagenes de la version 3.0 (1991) //
// (imagenes de 24 bits de apoyo) //
// //
// 2. No hay soporte de paleta //
// //
// 3. Sin comprimir archivos no son compatibles //
// //
// 4. AssignTo NO esta probado //
// //
// 5. GetEmpty NO esta probado //
// //
// 6. SaveToClipboardFormat NO esta probado //
// //
// 7. LoadFromClipboardFormat NO esta probado //
// //
// 8. La imagen SIEMPRE sera almacenado como una de 24 bits de la imagen pcx //
// //
////////////////////////////////////////////////////////////////////////
Unidad
& nbsp & nbsp & nbsp PCXImage
Interfaz
Usos
& nbsp & nbsp & nbsp Windows,
& nbsp & nbsp & nbsp SysUtils,
& nbsp & nbsp & nbsp Clases,
& nbsp & nbsp & nbsp Graficos
Const
& nbsp & nbsp & nbsp WIDTH_OUT_OF_RANGE = 'Ilegal ancho de la entrada en PCX encabezado del archivo'
& nbsp & nbsp & nbsp HEIGHT_OUT_OF_RANGE = 'Ilegal la altura de la entrada en PCX encabezado del archivo'
& nbsp & nbsp & nbsp FILE_FORMAT_ERROR = 'formato de archivo no Valido'
& nbsp & nbsp & nbsp VERSION_ERROR = 'Solo en PC Paintbrush (plus) V3.0 y superior
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp 'son compatibles'
& nbsp & nbsp & nbsp FORMAT_ERROR = 'Ilegal identificacion de bytes en el archivo PCX'
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp 'encabezado'
& nbsp & nbsp & nbsp PALETTE_ERROR = 'no Valido paleta encontrado'
& nbsp & nbsp & nbsp ASSIGN_ERROR = 'solo Puede Asignar un TBitmap o un TPicture'
& nbsp & nbsp & nbsp ASSIGNTO_ERROR = 'Solo puede AssignTo un TBitmap'
& nbsp & nbsp & nbsp PCXIMAGE_EMPTY = 'La imagen PCX esta vacio'
& nbsp & nbsp & nbsp BITMAP_EMPTY = 'El mapa de bits esta vacio'
& nbsp & nbsp & nbsp INPUT_FILE_TOO_LARGE = 'El archivo de entrada es demasiado grande para ser leido'
& nbsp & nbsp & nbsp IMAGE_WIDTH_TOO_LARGE = 'Ancho de la imagen PCX demasiado grande para manejar'
& nbsp & nbsp & nbsp // añadido 19/08/2001
& nbsp & nbsp & nbsp CLIPBOARD_LOAD_ERROR = 'Cargando desde el portapapeles error'
& nbsp & nbsp & nbsp // añadido 19/08/2001
& nbsp & nbsp & nbsp CLIPBOARD_SAVE_ERROR = 'Guardar en el portapapeles error'
& nbsp & nbsp & nbsp // añadido 14/10/2001
& nbsp & nbsp & nbsp PCX_WIDTH_ERROR = 'Inesperado de la anchura de la linea en PCX de datos'
& nbsp & nbsp & nbsp PCX_HEIGHT_ERROR = 'Mas PCX se han encontrado datos de la esperada'
& nbsp & nbsp & nbsp PCXIMAGE_TOO_LARGE = 'imagen PCX demasiado grande'
// añadido 19/08/2001
Var
& nbsp & nbsp & nbsp CF_PCX : Word
////////////////////////////////////////////////////////////////////////
// //
// PCXHeader //
// //
////////////////////////////////////////////////////////////////////////
Tipo
& nbsp & nbsp & nbsp ColorRecord = lleno de Registro
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp R,G,B : Byte
& nbsp & nbsp & nbsp Final // de Registro
Tipo
& nbsp & nbsp & nbsp TPCXImageHeader = lleno de Registro
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fID : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fVersion : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fCompressed : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fBitsPerPixel : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fWindow : lleno de Registro
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp wLeft,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp wTop,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp wRight,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp wBottom : WORD
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final // de concentrado de Registro
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fHorzResolution : La PALABRA
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fVertResolution : WORD
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fColorMap : Array[0..15] de ColorRecord
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fReserved : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPlanes : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fBytesPerLine : WORD
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPaletteInfo : WORD
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fFiller : Array[0..57] de Bytes
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final // de concentrado de Registro
////////////////////////////////////////////////////////////////////////
// //
// PCXData //
// //
////////////////////////////////////////////////////////////////////////
// Const
// fMaxDataFileLength = $7FFFFF // Max filelength 8,3 Mb
Tipo
& nbsp & nbsp & nbsp TPCXData = Objeto
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp // fData : Array[0..fMaxDataFileLength] de Bytes
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fData : Matriz de Bytes
& nbsp & nbsp & nbsp Final
////////////////////////////////////////////////////////////////////////
// //
// ScanLine //
// //
////////////////////////////////////////////////////////////////////////
Const
& nbsp & nbsp & nbsp fMaxScanLineLength = $FFF // Max ancho de la imagen: 4096 pixeles
Tipo
& nbsp & nbsp & nbsp mByteArray = Array[0..fMaxScanLineLength] de Bytes
& nbsp & nbsp & nbsp pmByteArray = ^mByteArray
// El 'estandar' pByteArray asigna 32768 bytes,
// que es un poco exagerado aqui, Yo creo que...
Const
& nbsp & nbsp & nbsp fMaxImageWidth = $FFF // Max ancho de la imagen: 4096 pixeles
Tipo
& nbsp & nbsp & nbsp xByteArray = Array[0..fMaxImageWidth] de Bytes
////////////////////////////////////////////////////////////////////////
// //
// PCXPalette //
// //
////////////////////////////////////////////////////////////////////////
Tipo
& nbsp & nbsp & nbsp fColorEntry = lleno de Registro
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp R,G,B : Byte
& nbsp & nbsp & nbsp Final // de concentrado de Registro
Tipo
& nbsp & nbsp & nbsp TPCXPalette = lleno de Registro
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fSignature : Byte
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPalette : Array[0..255] de fColorEntry
& nbsp & nbsp & nbsp Final // de concentrado de Registro
////////////////////////////////////////////////////////////////////////
// //
// Clases //
// //
////////////////////////////////////////////////////////////////////////
Tipo
& nbsp & nbsp & nbsp TPCXImage = Clase
& nbsp & nbsp & nbsp TPCXFile = Clase
////////////////////////////////////////////////////////////////////////
// //
// PCXFile //
// //
// Archivo de controlador //
// //
////////////////////////////////////////////////////////////////////////
TPCXFile = Clase(TPersistent)
& nbsp & nbsp & nbsp Privada
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fHeight : Integer
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fWidth : Integer
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXHeader : TPCXImageHeader
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXData : TPCXData
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXPalette : TPCXPalette
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fColorDepth : el Cardenal
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fCurrentPos : El cardenal
& nbsp & nbsp & nbsp Protegido
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { declaraciones Protegidos }
& nbsp & nbsp & nbsp Publica
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { Public declarations }
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp constructor Create
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp destructor Destruir reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento LoadFromFile(Const Filename : String)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento LoadFromStream(Stream : TStream)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SaveToFile(Const Filename : String)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SaveToStream(Stream : TStream)
& nbsp & nbsp & nbsp Publicado
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { Publicado declaraciones }
& nbsp & nbsp & nbsp & nbsp & nbsp - nbsp { La publicacion se realiza en el TPCXImage seccion }
Fin
////////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// //
// la Imagen de controlador //
// //
////////////////////////////////////////////////////////////////////////
TPCXImage = clase(TGraphic)
& nbsp & nbsp & nbsp Privada
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { Private declarations }
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fBitmap : TBitmap
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile : TPCXFile
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fRLine,fGLine,fBLine : xByteArray
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fP : pmByteArray
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento ConvertPCXDataToImage
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento ConvertImageToPCXData
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento FillDataLines(Const fLine : Array de Bytes)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento CreatePCXHeader
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp // Procedimiento ProcessLine(Var fLine : Array de Byte Const N : Cardinal)
& nbsp & nbsp & nbsp Protegido
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { declaraciones Protegidos }
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento de Sorteo(ACanvas : TCanvas Const Rect : TRect) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Funcion GetHeight : Integer reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Funcion GetWidth : Integer reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SetHeight(Valor : Integer) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SetWidth(Valor : Integer) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Funcion GetEmpty : Boolean reemplazar
& nbsp & nbsp & nbsp Publica
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { Public declarations }
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp // Procedimiento de Sorteo(ACanvas : TCanvas Const Rect : TRect) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp constructor de reemplazo de Crear
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp destructor Destruir reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento de Asignar(Fuente : TPersistent) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento AssignTo(Dest : TPersistent) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento LoadFromFile(const Filename : String) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento LoadFromStream(Stream : TStream) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SaveToFile(const Filename : String) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SaveToStream(Stream : TStream) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento LoadFromClipboardFormat(AFormat : Palabra AData : THandle
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp APalette : HPALETTE) reemplazar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Procedimiento SaveToClipboardFormat(Var AFormat : La palabra
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Var AData : THandle Var APalette : HPALETTE) reemplazar

& nbsp & nbsp & nbsp Publicado
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp { Publicado declaraciones }
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Propiedad de la Altura : Integer
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp leer GetHeight escribir SetHeight
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Propiedad Width : Integer
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp leer GetWidth escribir SetWidth
Fin
Aplicacion
////////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// //
// la Imagen de controlador //
// //
////////////////////////////////////////////////////////////////////////
constructor TPCXImage.Crear
Begin
heredado Crear
Si no Asignados(fBitmap), a continuacion,
& nbsp & nbsp & nbsp fBitmap := TBitmap.Crear
Si no Asignados(fPCXFile), a continuacion,
& nbsp & nbsp & nbsp fPCXFile := TPCXFile.Crear
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
destructor TPCXImage.Destruir
Begin
fPCXFile.Libre
fBitmap.Libre // Invierte el fin de crear
//SetLength(fRLine,0)
//Setlength(fGLine,0)
//SetLength(fBLine,0)
heredado Destruir
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.SetHeight(Valor : Integer)
Begin
Si el Valor >= 0,
& nbsp & nbsp & nbsp fBitmap.Altura := Valor
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.SetWidth(Valor : Integer)
Begin
Si el Valor >= 0,
& nbsp & nbsp & nbsp fBitmap.Ancho := Valor
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Funcion TPCXImage.GetHeight : Integer
Begin
Resultado := fPCXFile.fHeight
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Funcion TPCXImage.GetWidth : Integer
Begin
Resultado := fPCXFile.fWidth
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// Los creditos para este procedimiento se vaya a su trabajo de TGIFImage por /a/
// Reinier P. Sterkenburg //
// NO PROBADO! //
// añadido 19/08/2001 //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Procedimiento TPCXImage.LoadFromClipboardFormat(AFormat : Word
& nbsp & nbsp & nbsp ADAta : THandle APalette : HPALETTE)
Var
& nbsp & nbsp & nbsp Tamaño : Integer
& nbsp & nbsp & nbsp Buf : Puntero
& nbsp & nbsp & nbsp Stream : TMemoryStream
& nbsp & nbsp & nbsp BMP : TBitmap
Begin
Si (AData = 0) a continuacion,
& nbsp & nbsp & nbsp AData := GetClipBoardData(AFormat)
Si (AData <> 0) y (AFormat = CF_PCX), a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp Tamaño := GlobalSize(AData)
& nbsp & nbsp & nbsp Buf := GlobalLock(AData)
& nbsp & nbsp & nbsp Probar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Stream := TMemoryStream.Crear
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Probar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Corriente.SetSize(Tamaño)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Mover(Buf^,Arroyo.Memoria^,Tamaño)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Auto.LoadFromStream(Stream)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp finalmente
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Corriente.Libre
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp finalmente
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp GlobalUnlock(AData)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp Final
else
& nbsp & nbsp & nbsp Si (AData <> 0) y (AFormat = CF_BITMAP), a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp BMP := TBitmap.Crear
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Probar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp BMP.LoadFromClipboardFormat(AFormat,AData,APalette)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Auto.Asignar(BMP)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp finalmente
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp BMP.Libre
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp else
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Elevar la Excepcion.Crear(CLIPBOARD_LOAD_ERROR)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// Los creditos para este procedimiento se vaya a su trabajo de TGIFImage por /a/
// Reinier P. Sterkenburg //
// NO PROBADO! //
// añadido 19/08/2001 //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Procedimiento TPCXImage.SaveToClipboardFormat(Var AFormat : Word
& nbsp & nbsp & nbsp Var AData : THandle Var APalette : HPALETTE)
Var
& nbsp & nbsp & nbsp Stream : TMemoryStream
& nbsp & nbsp & nbsp Datos : THandle
& nbsp & nbsp & nbsp Buf : Puntero
Begin
Si esta Vacio, a continuacion,
& nbsp & nbsp & nbsp Salida
// Primera tienda en el mapa de bits al portapapeles
fBitmap.SaveToClipboardFormat(AFormat,AData,APalette)
// a Continuacion, intenta guardar el PCX
la Secuencia := TMemoryStream.Crear
prueba
& nbsp & nbsp & nbsp SaveToStream(Stream)
& nbsp & nbsp & nbsp Corriente.Posicion := 0
& nbsp & nbsp & nbsp Datos := GlobalAlloc(HeapAllocFlags,Arroyo.Tamaño)
& nbsp & nbsp & nbsp probar
& nbsp & nbsp & nbsp Si los Datos <> 0 then
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Buf := GlobalLock(Datos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp probar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Mover(Stream.Memoria^,Buf^,Arroyo.Tamaño)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp finalmente
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp GlobalUnlock(Datos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Si SetClipBoardData(CF_PCX,Datos) = 0, entonces
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Elevar la Excepcion.Crear(CLIPBOARD_SAVE_ERROR)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp excepto
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp GlobalFree(Datos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp elevar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp finalmente
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Corriente.Libre
& nbsp & nbsp & nbsp Final
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// NO PROBADO! //
// añadido 19/08/2001 //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Funcion TPCXImage.GetEmpty : Boolean
Begin
Si se ha Asignado(fBitmap), a continuacion,
& nbsp & nbsp & nbsp Resultado := fBitmap.Vacio
else
& nbsp & nbsp & nbsp Resultado := (fPCXFile.fHeight = 0) o (fPCXFile.fWidth = 0)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.SaveToFile(const Filename : String)
Var
& nbsp & nbsp & nbsp fPCX : TFileStream
Begin
Si (fBitmap.Ancho = 0) o (fBitmap.Altura = 0) entonces
& nbsp & nbsp & nbsp Elevar la Excepcion.Crear(BITMAP_EMPTY)
CreatePCXHeader
ConvertImageToPCXData
fPCX := TFileStream.Crear(nombre de archivo,fmCreate)
Prueba
& nbsp & nbsp & nbsp fPCX.Posicion := 0
& nbsp & nbsp & nbsp SaveToStream(fPCX)
finalmente
& nbsp & nbsp & nbsp fPCX.Libre
& nbsp & nbsp & nbsp Final
SetLength(fPCXFile.fPCXData.fData,0)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// NO PROBADO! //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Procedimiento TPCXImage.AssignTo(Dest : TPersistent)
Var
& nbsp & nbsp & nbsp bAssignToError : Boolean
Begin
bAssignToError := True
Si Dest es TBitmap, a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp (Dest como TBitmap).Asignar(fBitmap)
& nbsp & nbsp & nbsp bAssignToError := False
& nbsp & nbsp & nbsp Final
Si Dest es TPicture, a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp (Dest como TPicture).Grafico.Asignar(fBitmap)
& nbsp & nbsp & nbsp bAssignToError := False
& nbsp & nbsp & nbsp Final
Si bAssignToError, a continuacion,
& nbsp & nbsp & nbsp Elevar la Excepcion.Crear(ASSIGNTO_ERROR)
// Se puede escribir otras asignaciones aqui...
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Procedimiento TPCXImage.Asignar(Fuente : TPersistent)
Var
& nbsp & nbsp & nbsp iX,iY : Integer
& nbsp & nbsp & nbsp bAssignError : Boolean
Begin
bAssignError := True
Si (Fuente TBitmap), a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp fBitmap.Asignar(Fuente como TBitmap)

& nbsp & nbsp & nbsp bAssignError := False
& nbsp & nbsp & nbsp Final
Si (Fuente TPicture), a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp iX := (Fuente como TPicture).Anchura
& nbsp & nbsp & nbsp iY := (Fuente como TPicture).Altura
& nbsp & nbsp & nbsp fBitmap.Ancho := iX
& nbsp & nbsp & nbsp fBitmap.Altura := iY
& nbsp & nbsp & nbsp fBitmap.El lienzo.Dibujar(0,0,(Fuente como TPicture).El grafico)
& nbsp & nbsp & nbsp bAssignError := False
& nbsp & nbsp & nbsp Final
// Se puede escribir otras asignaciones aqui...
Si bAssignError, a continuacion,
& nbsp & nbsp & nbsp Elevar la Excepcion.Crear(ASSIGN_ERROR)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.Dibujar(ACanvas : TCanvas const Rect : TRect)
Begin
// ACanvas.Dibujar(0,0,fBitmap) // mas rapido
ACanvas.StretchDraw(Rect,fBitmap) // mas lento
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.LoadFromFile(const Filename : String)
Begin
fPCXFile.LoadFromFile(nombre de archivo)
ConvertPCXDataToImage
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.SaveToStream(Stream : TStream)
Begin
fPCXFile.SaveToStream(Stream)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
Procedimiento TPCXImage.LoadFromStream(Stream : TStream)
Begin
fPCXFile.LoadFromStream(Stream)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// Llamado por RLE compresor //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Procedimiento TPCXImage.FillDataLines(Const fLine : Array de Bytes)
Var
& nbsp & nbsp & nbsp : Byte
& nbsp & nbsp & nbsp Cnt : WORD
& nbsp & nbsp & nbsp I : Cardinal
& nbsp & nbsp & nbsp W : el Cardenal
Begin
I := 0
Por := fLine[0]
Cnt := $C1
W := fBitmap.Anchura
Repetir
& nbsp & nbsp & nbsp Inc(I)
& nbsp & nbsp & nbsp Si Por = fLine[I] entonces
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(Cnt)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Si Cnt = $100, a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Byte(Pred(Cnt))
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Por
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Cnt := $C1
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp := fLine[I]
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp If (<> fLine[I]) entonces
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Si (Cnt = $C1) a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp If (<$C1) a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Por
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp else
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Byte(Cnt)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Por
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp else
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Byte(Cnt)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Por
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Cnt := $C1
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp := fLine[I]
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
Hasta I = W - 1
// Escribir el ultimo byte(s)
Si (Cnt > $C1), a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Byte(Cnt)
& nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp Final
Si (Cnt = $C1) y (> $C0), a continuacion,
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Byte(Cnt)
& nbsp & nbsp & nbsp Inc(fPCXFile.fCurrentPos)
& nbsp & nbsp & nbsp Final
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Por
Inc(fPCXFile.fCurrentPos)
// Si fPCXFile.fCurrentPos > fMaxDataFileLength, a continuacion,
// subida de Excepcion.Crear(PCXIMAGE_TOO_LARGE)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
// RLE algoritmo de Compresion //
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & //
Procedimiento TPCXImage.ConvertImageToPCXData
Var
& nbsp & nbsp & nbsp H,W : el Cardenal
& nbsp & nbsp & nbsp X,Y : el Cardenal
& nbsp & nbsp & nbsp I : Cardinal
Begin
H := fBitmap.Altura
W := fBitmap.Anchura
fPCXFile.fCurrentPos := 0
SetLength(fPCXFile.fPCXData.fData,6 * W * H) // para estar seguro de que
// SetLength(fRLine,W)
// SetLength(fGLine,W)
// SetLength(fBLine,W)
fBitmap.PixelFormat := pf24bit // esto si usted esta utilizando el ScanLine!
Y := 0 para H - 1 hacer
& nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp fP := fBitmap.ScanLine[Y]
& nbsp & nbsp & nbsp I := 0
& nbsp & nbsp & nbsp X := 0 to W - 1 hacer
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fRLine[X] := fP[I] Inc(I) // Extracto de una linea roja
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fGLine[X] := fP[I] Inc(I) // Extracto de una linea verde
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp fBLine[X] := fP[I] Inc(I) // Extracto de una linea azul
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Final
& nbsp & nbsp & nbsp FillDataLines(fBLine) // Comprimir la linea azul
& nbsp & nbsp & nbsp FillDataLines(fGLine) // Comprimir la linea verde
& nbsp & nbsp & nbsp FillDataLines(fRLine) // Comprimir la linea roja
& nbsp & nbsp & nbsp Final

// Corregir la longitud de fPCXData.fData
SetLength(fPCXFile.fPCXData.fData,fPCXFile.fCurrentPos)
Fin
// & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & & &
(*
Procedimiento TPCXImage.ProcessLine(Var fLine : Array de Byte Const N : Cardinal)
Var
& nbsp & nbsp & nbsp Cnt : Integer
& nbsp & nbsp & nbsp J,K : Cardinal
& nbsp & nbsp & nbsp