Source code of file oscpmwin_v0.1.1.652/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 ((UPPERCASE (ExtractFileExt (ImageName)) = '.JPG') OR
0067: (UPPERCASE (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 (UPPERCASE (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 (UPPERCASE (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: FileStream.Read (ImgHeader, SIZEOF (ImgHeader));
0107: FINALLY
0108: FileStream.Free;
0109: END;
0110: IF (ImgHeader = 'GIF8') THEN
0111: FNopm_ImageNameIsGIF := TRUE
0112: ELSE
0113: FNopm_ImageNameIsGIF := FALSE;
0114: END;
0115:
0116:
0117: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0118: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0119: FUNCTION FNopm_SetQuality (NumericQuality : LONGINT) : LONGINT;
0120: BEGIN
0121: CASE ABS (NumericQuality) OF
0122: 76..100 : FNopm_SetQuality := JPEG_QUALITYSUPERB;
0123: 51..75 : FNopm_SetQuality := JPEG_QUALITYGOOD;
0124: 26..50 : FNopm_SetQuality := JPEG_QUALITYNORMAL;
0125: 11..25 : FNopm_SetQuality := JPEG_QUALITYAVERAGE;
0126: 0..10 : FNopm_SetQuality := JPEG_QUALITYBAD;
0127: ELSE
0128: FNopm_SetQuality := JPEG_DEFAULT;
0129: END;
0130: END;
0131:
0132:
0133: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0134: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0135: FUNCTION FNopm_QualityExplain (NumericQuality : INTEGER) : STRING;
0136: BEGIN
0137: CASE ABS (NumericQuality) OF
0138: 76..100 : FNopm_QualityExplain := _('Superb quality');
0139: 51..75 : FNopm_QualityExplain := _('Good quality');
0140: 26..50 : FNopm_QualityExplain := _('Normal quality');
0141: 11..25 : FNopm_QualityExplain := _('Average quality');
0142: 0..10 : FNopm_QualityExplain := _('Bad quality');
0143: ELSE
0144: FNopm_QualityExplain := '';
0145: END;
0146: END;
0147:
0148:
0149:
0150: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0151: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0152: FUNCTION FNopm_ConvertImage2 (ImageName, DestName : STRING; TargetFormat : FREE_IMAGE_FORMAT; JPEGQuality : LONGINT) : BOOLEAN;
0153: VAR
0154: DIB1, DIB2 : FIBITMAP;
0155: ImageFormat : FREE_IMAGE_FORMAT;
0156: BEGIN
0157: FNopm_ConvertImage2 := FALSE;
0158: DIB1 := NIL;
0159: DIB2 := NIL;
0160: IF ((ImageName <> '') AND (DestName <> '')) THEN
0161: BEGIN
0162: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0163: IF (ImageFormat <> opmC_NAFormat) THEN
0164: TRY
0165: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0166: IF (DIB1 <> NIL) THEN
0167: BEGIN
0168: TRY
0169: CASE TargetFormat OF
0170: opmC_BMPFormat :
0171: FreeImage_Save (opmC_BMPFormat, DIB1, PCHAR (DestName), 0);
0172: opmC_GIFFormat :
0173: FreeImage_Save (opmC_GIFFormat, DIB1, PCHAR (DestName), 0);
0174: opmC_PNGFormat :
0175: TRY
0176: DIB2 := FreeImage_ColorQuantize (DIB1, FIQ_NNQUANT); {Convert to 8 bits...}
0177: FreeImage_Save (opmC_PNGFormat, DIB2, PCHAR (DestName), 0);
0178: FINALLY
0179: FreeImage_Unload (DIB2);
0180: END;
0181: opmC_JPEGFormat :
0182: FreeImage_Save (opmC_JPEGFormat, DIB1, PCHAR (DestName), FNopm_SetQuality (JPEGQuality));
0183: END;
0184: FNopm_ConvertImage2 := TRUE;
0185: EXCEPT
0186: FNopm_ConvertImage2 := FALSE;
0187: END;
0188: END;
0189: FINALLY
0190: FreeImage_Unload (DIB1);
0191: END;
0192: END;
0193: END;
0194:
0195:
0196: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0197: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0198: FUNCTION FNopm_ResizeImage2 (ImageName, DestName : STRING; XSize, YSize : LONGINT;
0199: KeepAspect, PadImage : LONGINT; PadColor : LONGINT) : BOOLEAN;
0200: VAR
0201: DIB1, DIB2, DIB3, DIB4, DIB5, DIB6 : FIBITMAP;
0202: ImageFormat : FREE_IMAGE_FORMAT;
0203: XRatio, YRatio : REAL;
0204: XCurrent, YCurrent : LONGINT;
0205: NewXSize, NewYSize : LONGINT;
0206: BackColor : PRGBQUAD;
0207: BEGIN
0208: FNopm_ResizeImage2 := FALSE;
0209: DIB1 := NIL;
0210: DIB2 := NIL;
0211: DIB3 := NIL;
0212: DIB4 := NIL;
0213: DIB5 := NIL;
0214: DIB6 := NIL;
0215: BackColor := NIL;
0216: IF ((ImageName <> '') AND (DestName <> '')) THEN
0217: BEGIN
0218: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0219: IF (ImageFormat <> opmC_NAFormat) THEN
0220: TRY
0221: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0222: IF (DIB1 <> NIL) THEN
0223: BEGIN
0224: IF (KeepAspect > 0) THEN
0225: BEGIN
0226: XCurrent := FreeImage_GetWidth (DIB1);
0227: YCurrent := FreeImage_GetHeight (DIB1);
0228: XRatio := (XCurrent / XSize);
0229: YRatio := (YCurrent / YSize);
0230: IF (XRatio > YRatio) THEN
0231: BEGIN
0232: NewXSize := ROUND (XCurrent / XRatio);
0233: NewYSize := ROUND (YCurrent / XRatio);
0234: END
0235: ELSE
0236: BEGIN
0237: NewXSize := ROUND (XCurrent / YRatio);
0238: NewYSize := ROUND (YCurrent / YRatio);
0239: END;
0240: END
0241: ELSE
0242: BEGIN
0243: NewXSize := XSize;
0244: NewYSize := YSize;
0245: END;
0246: TRY
0247: DIB2 := FreeImage_ConvertTo32Bits (DIB1);
0248: DIB3 := FreeImage_Rescale (DIB2, NewXSize, NewYSize, FILTER_CATMULLROM);
0249: DIB4 := FreeImage_ConvertTo24Bits (DIB3);
0250: IF (PadImage > 0) THEN
0251: TRY
0252: DIB5 := FreeImage_Allocate (XSize, YSize, 24);
0253: NEW (BackColor);
0254: BackColor^.rgbRed := GetRValue (PadColor);
0255: BackColor^.rgbGreen := GetGValue (PadColor);
0256: BackColor^.rgbBlue := GetBValue (PadColor);
0257: BackColor^.rgbReserved := 0;
0258: {FreeImage_SetBackgroundColor (DIB5, BackColor);}
0259: FOR XCurrent := 0 TO (XSize - 1) DO
0260: FOR YCurrent := 0 TO (YSize - 1) DO
0261: FreeImage_SetPixelColor (DIB5, XCurrent, YCurrent, BackColor);
0262: DIB6 := FreeImage_Copy (DIB4, 0, 0, (NewXSize - 1), (NewYSize - 1));
0263: FreeImage_Paste (DIB5, DIB6, ROUND ((XSize - NewXSize) / 2), ROUND ((YSize - NewYSize) / 2), 255);
0264: FreeImage_Save (opmC_BMPFormat, DIB5, PCHAR (DestName), 0);
0265: FINALLY
0266: FreeImage_Unload (DIB5);
0267: FreeImage_Unload (DIB6);
0268: DISPOSE (BackColor);
0269: END
0270: ELSE FreeImage_Save (opmC_BMPFormat, DIB4, PCHAR (DestName), 0);
0271: FNopm_ResizeImage2 := TRUE;
0272: FINALLY
0273: FreeImage_Unload (DIB2);
0274: FreeImage_Unload (DIB3);
0275: FreeImage_Unload (DIB4);
0276: END;
0277: END;
0278: FINALLY
0279: FreeImage_Unload (DIB1);
0280: END;
0281: END;
0282: END;
0283:
0284:
0285:
0286: END.
