Source code of file oscpmwin_v0.1.2.189/imageman.pas from the
osCommerce Product Manager for Windows.
0000: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
0001: osCommerce Product Manager for Windows (oscpmwin).
0002: 0003:
0004: You can contact Mario A. Valdez-Ramirez
0005: by email at mario@mariovaldez.org or paper mail at
0006: Olmos 809, San Nicolas, NL. 66495, Mexico.
0007:
0008: This program is free software; you can redistribute it and/or modify
0009: it under the terms of the GNU General Public License as published by
0010: the Free Software Foundation; either version 2 of the License, or (at
0011: your option) any later version.
0012:
0013: This program is distributed in the hope that it will be useful, but
0014: WITHOUT ANY WARRANTY; without even the implied warranty of
0015: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
0016: General Public License for more details.
0017:
0018: You should have received a copy of the GNU General Public License
0019: along with this program; if not, write to the Free Software
0020: Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
0021: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0022: UNIT imageman;
0023:
0024: INTERFACE
0025:
0026: USES
0027: FreeImage, SysUtils;
0028:
0029:
0030:
0031: CONST
0032: opmC_BMPFormat = FIF_BMP;
0033: opmC_JPEGFormat = FIF_JPEG;
0034: opmC_PNGFormat = FIF_PNG;
0035: opmC_GIFFormat = FIF_GIF;
0036: opmC_NAFormat = FIF_UNKNOWN;
0037: opmC_TmpImg_Filename = 'oscpmtmp.img';
0038: opmC_TmpBMP_Filename = 'oscpmtmp.bmp';
0039: opmC_TmpJPG_Filename = 'oscpmtmp.jpg';
0040: opmC_TmpPNG_Filename = 'oscpmtmp.png';
0041: opmC_TmpGIF_Filename = 'oscpmtmp.gif';
0042: opmC_Def_UploadExt = 'jpg';
0043: opmC_Def_UploadFilename = '';
0044: opmC_Def_UploadFilter = '*.jpg;*.png;*.gif;*.bmp;*.pcx;*.psd;*.xbm;*.xpm';
0045:
0046:
0047: FUNCTION FNopm_ImageNameIsJPEG (ImageName : STRING) : BOOLEAN;
0048: FUNCTION FNopm_ImageNameIsPNG (ImageName : STRING) : BOOLEAN;
0049: FUNCTION FNopm_ImageNameIsGIF2 (ImageName : STRING) : BOOLEAN;
0050: FUNCTION FNopm_SetQuality (NumericQuality : LONGINT) : LONGINT;
0051: FUNCTION FNopm_QualityExplain (NumericQuality : INTEGER) : STRING;
0052: FUNCTION FNopm_ConvertImage2 (ImageName, DestName : STRING; TargetFormat : FREE_IMAGE_FORMAT; JPEGQuality : LONGINT) : BOOLEAN;
0053: FUNCTION FNopm_ResizeImage2 (ImageName, DestName : STRING; XSize, YSize : LONGINT; KeepAspect, PadImage : LONGINT; PadColor : LONGINT) : BOOLEAN;
0054:
0055:
0056:
0057: IMPLEMENTATION
0058:
0059: USES gnugettext, ShellApi, Forms, Windows, Classes, dataman;
0060:
0061:
0062: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0063: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0064: FUNCTION FNopm_ImageNameIsJPEG (ImageName : STRING) : BOOLEAN;
0065: BEGIN
0066: IF ((ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.JPG') OR
0067: (ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.JPEG')) THEN
0068: FNopm_ImageNameIsJPEG := TRUE
0069: ELSE
0070: FNopm_ImageNameIsJPEG := FALSE;
0071: END;
0072:
0073:
0074: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0075: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0076: FUNCTION FNopm_ImageNameIsPNG (ImageName : STRING) : BOOLEAN;
0077: BEGIN
0078: IF (ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.PNG') THEN
0079: FNopm_ImageNameIsPNG := TRUE
0080: ELSE
0081: FNopm_ImageNameIsPNG := FALSE;
0082: END;
0083:
0084:
0085: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0086: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0087: FUNCTION FNopm_ImageNameIsGIF2 (ImageName : STRING) : BOOLEAN;
0088: BEGIN
0089: IF (ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.GIF') THEN
0090: FNopm_ImageNameIsGIF2 := TRUE
0091: ELSE
0092: FNopm_ImageNameIsGIF2 := FALSE;
0093: END;
0094:
0095:
0096: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0097: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0098: FUNCTION FNopm_ImageNameIsGIF (ImageName : STRING) : BOOLEAN;
0099: VAR
0100: FileStream : TFileStream;
0101: ImgHeader : ARRAY [0..3] OF CHAR;
0102: BEGIN
0103: IF (ImageName <> '') THEN
0104: TRY
0105: FileStream := TFileStream.Create (ImageName, fmOpenRead);
0106: TRY
0107: FileStream.Read (ImgHeader, SIZEOF (ImgHeader));
0108: FINALLY
0109: FileStream.Free;
0110: END;
0111: EXCEPT
0112: ImgHeader := '';
0113: END;
0114: IF (ImgHeader = 'GIF8') THEN
0115: FNopm_ImageNameIsGIF := TRUE
0116: ELSE
0117: FNopm_ImageNameIsGIF := FALSE;
0118: END;
0119:
0120:
0121: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0122: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0123: FUNCTION FNopm_SetQuality (NumericQuality : LONGINT) : LONGINT;
0124: BEGIN
0125: CASE ABS (NumericQuality) OF
0126: 76..100 : FNopm_SetQuality := JPEG_QUALITYSUPERB;
0127: 51..75 : FNopm_SetQuality := JPEG_QUALITYGOOD;
0128: 26..50 : FNopm_SetQuality := JPEG_QUALITYNORMAL;
0129: 11..25 : FNopm_SetQuality := JPEG_QUALITYAVERAGE;
0130: 0..10 : FNopm_SetQuality := JPEG_QUALITYBAD;
0131: ELSE
0132: FNopm_SetQuality := JPEG_DEFAULT;
0133: END;
0134: END;
0135:
0136:
0137: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0138: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0139: FUNCTION FNopm_QualityExplain (NumericQuality : INTEGER) : STRING;
0140: BEGIN
0141: CASE ABS (NumericQuality) OF
0142: 76..100 : FNopm_QualityExplain := _('Superb quality');
0143: 51..75 : FNopm_QualityExplain := _('Good quality');
0144: 26..50 : FNopm_QualityExplain := _('Normal quality');
0145: 11..25 : FNopm_QualityExplain := _('Average quality');
0146: 0..10 : FNopm_QualityExplain := _('Bad quality');
0147: ELSE
0148: FNopm_QualityExplain := '';
0149: END;
0150: END;
0151:
0152:
0153:
0154: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0155: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0156: FUNCTION FNopm_ConvertImage2 (ImageName, DestName : STRING; TargetFormat : FREE_IMAGE_FORMAT; JPEGQuality : LONGINT) : BOOLEAN;
0157: VAR
0158: DIB1, DIB2 : FIBITMAP;
0159: ImageFormat : FREE_IMAGE_FORMAT;
0160: BEGIN
0161: FNopm_ConvertImage2 := FALSE;
0162: DIB1 := NIL;
0163: DIB2 := NIL;
0164: IF ((ImageName <> '') AND (DestName <> '')) THEN
0165: BEGIN
0166: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0167: IF (ImageFormat <> opmC_NAFormat) THEN
0168: TRY
0169: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0170: IF (DIB1 <> NIL) THEN
0171: BEGIN
0172: TRY
0173: CASE TargetFormat OF
0174: opmC_BMPFormat :
0175: FreeImage_Save (opmC_BMPFormat, DIB1, PCHAR (DestName), 0);
0176: opmC_GIFFormat :
0177: FreeImage_Save (opmC_GIFFormat, DIB1, PCHAR (DestName), 0);
0178: opmC_PNGFormat :
0179: TRY
0180: DIB2 := FreeImage_ColorQuantize (DIB1, FIQ_NNQUANT); {Convert to 8 bits...}
0181: FreeImage_Save (opmC_PNGFormat, DIB2, PCHAR (DestName), 0);
0182: FINALLY
0183: FreeImage_Unload (DIB2);
0184: END;
0185: opmC_JPEGFormat :
0186: FreeImage_Save (opmC_JPEGFormat, DIB1, PCHAR (DestName), FNopm_SetQuality (JPEGQuality));
0187: END;
0188: FNopm_ConvertImage2 := TRUE;
0189: EXCEPT
0190: FNopm_ConvertImage2 := FALSE;
0191: END;
0192: END;
0193: FINALLY
0194: FreeImage_Unload (DIB1);
0195: END;
0196: END;
0197: END;
0198:
0199:
0200: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0201: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0202: FUNCTION FNopm_ResizeImage2 (ImageName, DestName : STRING; XSize, YSize : LONGINT;
0203: KeepAspect, PadImage : LONGINT; PadColor : LONGINT) : BOOLEAN;
0204: VAR
0205: DIB1, DIB2, DIB3, DIB4, DIB5, DIB6 : FIBITMAP;
0206: ImageFormat : FREE_IMAGE_FORMAT;
0207: XRatio, YRatio : DOUBLE;
0208: XCurrent, YCurrent : LONGINT;
0209: NewXSize, NewYSize : LONGINT;
0210: BackColor : PRGBQUAD;
0211: BEGIN
0212: FNopm_ResizeImage2 := FALSE;
0213: DIB1 := NIL;
0214: DIB2 := NIL;
0215: DIB3 := NIL;
0216: DIB4 := NIL;
0217: DIB5 := NIL;
0218: DIB6 := NIL;
0219: BackColor := NIL;
0220: IF ((ImageName <> '') AND (DestName <> '')) THEN
0221: BEGIN
0222: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0223: IF (ImageFormat <> opmC_NAFormat) THEN
0224: TRY
0225: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0226: IF (DIB1 <> NIL) THEN
0227: BEGIN
0228: IF (KeepAspect > 0) THEN
0229: BEGIN
0230: XCurrent := FreeImage_GetWidth (DIB1);
0231: YCurrent := FreeImage_GetHeight (DIB1);
0232: XRatio := (XCurrent / XSize);
0233: YRatio := (YCurrent / YSize);
0234: IF (XRatio > YRatio) THEN
0235: BEGIN
0236: NewXSize := ROUND (XCurrent / XRatio);
0237: NewYSize := ROUND (YCurrent / XRatio);
0238: END
0239: ELSE
0240: BEGIN
0241: NewXSize := ROUND (XCurrent / YRatio);
0242: NewYSize := ROUND (YCurrent / YRatio);
0243: END;
0244: END
0245: ELSE
0246: BEGIN
0247: NewXSize := XSize;
0248: NewYSize := YSize;
0249: END;
0250: TRY
0251: DIB2 := FreeImage_ConvertTo32Bits (DIB1);
0252: DIB3 := FreeImage_Rescale (DIB2, NewXSize, NewYSize, FILTER_CATMULLROM);
0253: DIB4 := FreeImage_ConvertTo24Bits (DIB3);
0254: IF (PadImage > 0) THEN
0255: TRY
0256: DIB5 := FreeImage_Allocate (XSize, YSize, 24);
0257: NEW (BackColor);
0258: BackColor^.rgbRed := GetRValue (PadColor);
0259: BackColor^.rgbGreen := GetGValue (PadColor);
0260: BackColor^.rgbBlue := GetBValue (PadColor);
0261: BackColor^.rgbReserved := 0;
0262: {FreeImage_SetBackgroundColor (DIB5, BackColor);}
0263: FOR XCurrent := 0 TO (XSize - 1) DO
0264: FOR YCurrent := 0 TO (YSize - 1) DO
0265: FreeImage_SetPixelColor (DIB5, XCurrent, YCurrent, BackColor);
0266: DIB6 := FreeImage_Copy (DIB4, 0, 0, (NewXSize - 1), (NewYSize - 1));
0267: FreeImage_Paste (DIB5, DIB6, ROUND ((XSize - NewXSize) / 2), ROUND ((YSize - NewYSize) / 2), 255);
0268: FreeImage_Save (opmC_BMPFormat, DIB5, PCHAR (DestName), 0);
0269: FINALLY
0270: FreeImage_Unload (DIB5);
0271: FreeImage_Unload (DIB6);
0272: DISPOSE (BackColor);
0273: END
0274: ELSE FreeImage_Save (opmC_BMPFormat, DIB4, PCHAR (DestName), 0);
0275: FNopm_ResizeImage2 := TRUE;
0276: FINALLY
0277: FreeImage_Unload (DIB2);
0278: FreeImage_Unload (DIB3);
0279: FreeImage_Unload (DIB4);
0280: END;
0281: END;
0282: FINALLY
0283: FreeImage_Unload (DIB1);
0284: END;
0285: END;
0286: END;
0287:
0288:
0289:
0290: END.
