Source code of file oscpmwin_v0.1.2.450/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: Windows, Graphics, 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_TmpLoad_Filename = 'oscpmtmp.tmp';
0038: opmC_TmpImg_Filename = 'oscpmtmp.img';
0039: opmC_TmpBMP_Filename = 'oscpmtmp.bmp';
0040: opmC_TmpJPG_Filename = 'oscpmtmp.jpg';
0041: opmC_TmpPNG_Filename = 'oscpmtmp.png';
0042: opmC_TmpGIF_Filename = 'oscpmtmp.gif';
0043: opmC_Def_UploadExt = 'jpg';
0044: opmC_Def_UploadFilename = '';
0045: opmC_Def_UploadFilter = '*.jpg;*.png;*.tif;*.gif;*.bmp;*.pcx;*.psd;*.tga;*.xbm;*.xpm';
0046:
0047:
0048:
0049: TYPE
0050:
0051: opmT_GenericBitmap = CLASS (TBitmap)
0052: PUBLIC
0053: PROCEDURE LoadFromFile (CONST GrahicFileName : STRING); OVERRIDE;
0054: END;
0055:
0056:
0057: FUNCTION FNopm_ImageNameIsJPEG (ImageName : STRING) : BOOLEAN;
0058: FUNCTION FNopm_ImageNameIsPNG (ImageName : STRING) : BOOLEAN;
0059: FUNCTION FNopm_ImageNameIsGIF2 (ImageName : STRING) : BOOLEAN;
0060: FUNCTION FNopm_SetQuality (NumericQuality : LONGINT) : LONGINT;
0061: FUNCTION FNopm_QualityExplain (NumericQuality : INTEGER) : STRING;
0062: FUNCTION FNopm_ConvertImage2 (ImageName, DestName : STRING; TargetFormat : FREE_IMAGE_FORMAT; JPEGQuality : LONGINT; CommentStr : STRING) : BOOLEAN;
0063: FUNCTION FNopm_DirtyConvertImage (ImageName, DestName : STRING) : BOOLEAN;
0064: FUNCTION FNopm_ResizeImage2 (ImageName, DestName : STRING; XSize, YSize : LONGINT; KeepAspect, PadImage : LONGINT; PadColor : LONGINT) : BOOLEAN;
0065: PROCEDURE PRopm_AttachComment (VAR ImageDIB : FIBITMAP; CommentStr : STRING);
0066:
0067:
0068: VAR
0069: opmG_ImgTMPPath : STRING;
0070:
0071:
0072: IMPLEMENTATION
0073:
0074: USES gnugettext, ShellApi, Forms, Classes, dataman;
0075:
0076:
0077:
0078:
0079: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0080: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0081: PROCEDURE opmT_GenericBitmap.LoadFromFile (CONST GrahicFileName : STRING);
0082: VAR
0083: GenDIB : TBITMAP;
0084: BEGIN
0085: IF (FNopm_DirtyConvertImage (GrahicFileName, opmG_ImgTMPPath + opmC_TmpLoad_Filename) = TRUE) THEN
0086: BEGIN
0087: TRY
0088: GenDIB := TBitmap.Create;
0089: TRY
0090: GenDIB.LoadFromFile (opmG_ImgTMPPath + opmC_TmpLoad_Filename);
0091: Assign (GenDIB);
0092: FINALLY
0093: GenDIB.Free;
0094: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpLoad_Filename);
0095: END;
0096: EXCEPT
0097: END;
0098: END
0099: ELSE
0100: RAISE EInvalidGraphic.Create ('Invalid image!');
0101: END;
0102:
0103:
0104:
0105:
0106: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0107: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0108: FUNCTION FNopm_ImageNameIsJPEG (ImageName : STRING) : BOOLEAN;
0109: BEGIN
0110: IF ((ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.JPG') OR
0111: (ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.JPEG')) THEN
0112: FNopm_ImageNameIsJPEG := TRUE
0113: ELSE
0114: FNopm_ImageNameIsJPEG := FALSE;
0115: END;
0116:
0117:
0118: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0119: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0120: FUNCTION FNopm_ImageNameIsPNG (ImageName : STRING) : BOOLEAN;
0121: BEGIN
0122: IF (ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.PNG') THEN
0123: FNopm_ImageNameIsPNG := TRUE
0124: ELSE
0125: FNopm_ImageNameIsPNG := FALSE;
0126: END;
0127:
0128:
0129: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0130: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0131: FUNCTION FNopm_ImageNameIsGIF2 (ImageName : STRING) : BOOLEAN;
0132: BEGIN
0133: IF (ANSIUPPERCASE (ExtractFileExt (ImageName)) = '.GIF') THEN
0134: FNopm_ImageNameIsGIF2 := TRUE
0135: ELSE
0136: FNopm_ImageNameIsGIF2 := FALSE;
0137: END;
0138:
0139:
0140: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0141: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0142: FUNCTION FNopm_ImageNameIsGIF (ImageName : STRING) : BOOLEAN;
0143: VAR
0144: FileStream : TFileStream;
0145: ImgHeader : ARRAY [0..3] OF CHAR;
0146: BEGIN
0147: IF (ImageName <> '') THEN
0148: TRY
0149: FileStream := TFileStream.Create (ImageName, fmOpenRead);
0150: TRY
0151: FileStream.Read (ImgHeader, SIZEOF (ImgHeader));
0152: FINALLY
0153: FileStream.Free;
0154: END;
0155: EXCEPT
0156: ImgHeader := '';
0157: END;
0158: IF (ImgHeader = 'GIF8') THEN
0159: FNopm_ImageNameIsGIF := TRUE
0160: ELSE
0161: FNopm_ImageNameIsGIF := FALSE;
0162: END;
0163:
0164:
0165: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0166: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0167: FUNCTION FNopm_SetQuality (NumericQuality : LONGINT) : LONGINT;
0168: BEGIN
0169: CASE ABS (NumericQuality) OF
0170: 76..100 : FNopm_SetQuality := JPEG_QUALITYSUPERB;
0171: 51..75 : FNopm_SetQuality := JPEG_QUALITYGOOD;
0172: 26..50 : FNopm_SetQuality := JPEG_QUALITYNORMAL;
0173: 11..25 : FNopm_SetQuality := JPEG_QUALITYAVERAGE;
0174: 0..10 : FNopm_SetQuality := JPEG_QUALITYBAD;
0175: ELSE
0176: FNopm_SetQuality := JPEG_DEFAULT;
0177: END;
0178: END;
0179:
0180:
0181: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0182: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0183: FUNCTION FNopm_QualityExplain (NumericQuality : INTEGER) : STRING;
0184: BEGIN
0185: CASE ABS (NumericQuality) OF
0186: 76..100 : FNopm_QualityExplain := _('Superb quality');
0187: 51..75 : FNopm_QualityExplain := _('Good quality');
0188: 26..50 : FNopm_QualityExplain := _('Normal quality');
0189: 11..25 : FNopm_QualityExplain := _('Average quality');
0190: 0..10 : FNopm_QualityExplain := _('Bad quality');
0191: ELSE
0192: FNopm_QualityExplain := '';
0193: END;
0194: END;
0195:
0196:
0197:
0198: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0199: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0200: FUNCTION FNopm_ConvertImage2 (ImageName, DestName : STRING; TargetFormat : FREE_IMAGE_FORMAT; JPEGQuality : LONGINT; CommentStr : STRING) : BOOLEAN;
0201: VAR
0202: DIB1, DIB2 : FIBITMAP;
0203: ImageFormat : FREE_IMAGE_FORMAT;
0204: BEGIN
0205: FNopm_ConvertImage2 := FALSE;
0206: DIB1 := NIL;
0207: DIB2 := NIL;
0208: IF ((ImageName <> '') AND (DestName <> '')) THEN
0209: BEGIN
0210: SysUtils.DELETEFILE (DestName);
0211: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0212: IF (ImageFormat <> opmC_NAFormat) THEN
0213: TRY
0214: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0215: IF (DIB1 <> NIL) THEN
0216: BEGIN
0217: TRY
0218: CASE TargetFormat OF
0219: opmC_BMPFormat :
0220: IF (JPEGQuality > 0) THEN
0221: BEGIN
0222: PRopm_AttachComment (DIB1, CommentStr);
0223: FreeImage_Save (opmC_BMPFormat, DIB1, PCHAR (DestName), 0);
0224: END
0225: ELSE
0226: IF (FreeImage_GetBPP (DIB1) > 8) THEN
0227: TRY
0228: IF (JPEGQuality > 50) THEN
0229: DIB2 := FreeImage_ColorQuantize (DIB1, FIQ_NNQUANT)
0230: ELSE
0231: DIB2 := FreeImage_ColorQuantize (DIB1, FIQ_WUQUANT);
0232: PRopm_AttachComment (DIB2, CommentStr);
0233: FreeImage_Save (opmC_BMPFormat, DIB2, PCHAR (DestName), 0);
0234: FINALLY
0235: FreeImage_Unload (DIB2);
0236: END
0237: ELSE
0238: BEGIN
0239: PRopm_AttachComment (DIB1, CommentStr);
0240: FreeImage_Save (opmC_BMPFormat, DIB1, PCHAR (DestName), 0);
0241: END;
0242: opmC_PNGFormat :
0243: IF (JPEGQuality > 0) THEN
0244: BEGIN
0245: PRopm_AttachComment (DIB1, CommentStr);
0246: FreeImage_Save (opmC_PNGFormat, DIB1, PCHAR (DestName), 0);
0247: END
0248: ELSE
0249: TRY
0250: IF (JPEGQuality > 50) THEN
0251: DIB2 := FreeImage_ColorQuantize (DIB1, FIQ_NNQUANT)
0252: ELSE
0253: DIB2 := FreeImage_ColorQuantize (DIB1, FIQ_WUQUANT);
0254: PRopm_AttachComment (DIB2, CommentStr);
0255: FreeImage_Save (opmC_PNGFormat, DIB2, PCHAR (DestName), 0);
0256: FINALLY
0257: FreeImage_Unload (DIB2);
0258: END;
0259: opmC_JPEGFormat :
0260: BEGIN
0261: PRopm_AttachComment (DIB1, CommentStr);
0262: FreeImage_Save (opmC_JPEGFormat, DIB1, PCHAR (DestName), FNopm_SetQuality (JPEGQuality));
0263: END;
0264: END;
0265: FNopm_ConvertImage2 := TRUE;
0266: EXCEPT
0267: FNopm_ConvertImage2 := FALSE;
0268: END;
0269: END;
0270: FINALLY
0271: FreeImage_Unload (DIB1);
0272: END;
0273: END;
0274: END;
0275:
0276:
0277: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0278: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0279: FUNCTION FNopm_DirtyConvertImage (ImageName, DestName : STRING) : BOOLEAN;
0280: VAR
0281: DIB1 : FIBITMAP;
0282: ImageFormat : FREE_IMAGE_FORMAT;
0283: BEGIN
0284: FNopm_DirtyConvertImage := FALSE;
0285: DIB1 := NIL;
0286: IF ((ImageName <> '') AND (DestName <> '')) THEN
0287: BEGIN
0288: SysUtils.DELETEFILE (DestName);
0289: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0290: IF (ImageFormat <> opmC_NAFormat) THEN
0291: TRY
0292: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0293: IF (DIB1 <> NIL) THEN
0294: BEGIN
0295: TRY
0296: FreeImage_Save (opmC_BMPFormat, DIB1, PCHAR (DestName), 0);
0297: FNopm_DirtyConvertImage := TRUE;
0298: EXCEPT
0299: FNopm_DirtyConvertImage := FALSE;
0300: END;
0301: END;
0302: FINALLY
0303: FreeImage_Unload (DIB1);
0304: END;
0305: END;
0306: END;
0307:
0308:
0309: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0310: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0311: FUNCTION FNopm_ResizeImage2 (ImageName, DestName : STRING; XSize, YSize : LONGINT;
0312: KeepAspect, PadImage : LONGINT; PadColor : LONGINT) : BOOLEAN;
0313: VAR
0314: DIB1, DIB2, DIB3, DIB4, DIB5, DIB6 : FIBITMAP;
0315: ImageFormat : FREE_IMAGE_FORMAT;
0316: XRatio, YRatio : DOUBLE;
0317: XCurrent, YCurrent : LONGINT;
0318: NewXSize, NewYSize : LONGINT;
0319: BackColor : PRGBQUAD;
0320: BEGIN
0321: FNopm_ResizeImage2 := FALSE;
0322: DIB1 := NIL;
0323: DIB2 := NIL;
0324: DIB3 := NIL;
0325: DIB4 := NIL;
0326: DIB5 := NIL;
0327: DIB6 := NIL;
0328: BackColor := NIL;
0329: IF ((ImageName <> '') AND (DestName <> '')) THEN
0330: BEGIN
0331: SysUtils.DELETEFILE (DestName);
0332: ImageFormat := FreeImage_GetFileType (PCHAR (ImageName), 0);
0333: IF (ImageFormat <> opmC_NAFormat) THEN
0334: TRY
0335: DIB1 := FreeImage_Load (ImageFormat, PCHAR (ImageName), 0);
0336: IF (DIB1 <> NIL) THEN
0337: BEGIN
0338: IF (KeepAspect > 0) THEN
0339: BEGIN
0340: XCurrent := FreeImage_GetWidth (DIB1);
0341: YCurrent := FreeImage_GetHeight (DIB1);
0342: XRatio := (XCurrent / XSize);
0343: YRatio := (YCurrent / YSize);
0344: IF (XRatio > YRatio) THEN
0345: BEGIN
0346: NewXSize := ROUND (XCurrent / XRatio);
0347: NewYSize := ROUND (YCurrent / XRatio);
0348: END
0349: ELSE
0350: BEGIN
0351: NewXSize := ROUND (XCurrent / YRatio);
0352: NewYSize := ROUND (YCurrent / YRatio);
0353: END;
0354: END
0355: ELSE
0356: BEGIN
0357: NewXSize := XSize;
0358: NewYSize := YSize;
0359: END;
0360: TRY
0361: DIB2 := FreeImage_ConvertTo32Bits (DIB1);
0362: DIB3 := FreeImage_Rescale (DIB2, NewXSize, NewYSize, FILTER_CATMULLROM);
0363: DIB4 := FreeImage_ConvertTo24Bits (DIB3);
0364: IF (PadImage > 0) THEN
0365: TRY
0366: DIB5 := FreeImage_Allocate (XSize, YSize, 24);
0367: NEW (BackColor);
0368: BackColor^.rgbRed := GetRValue (PadColor);
0369: BackColor^.rgbGreen := GetGValue (PadColor);
0370: BackColor^.rgbBlue := GetBValue (PadColor);
0371: BackColor^.rgbReserved := 0;
0372: FOR XCurrent := 0 TO (XSize - 1) DO
0373: FOR YCurrent := 0 TO (YSize - 1) DO
0374: FreeImage_SetPixelColor (DIB5, XCurrent, YCurrent, BackColor);
0375: DIB6 := FreeImage_Copy (DIB4, 0, 0, (NewXSize - 1), (NewYSize - 1));
0376: FreeImage_Paste (DIB5, DIB6, ROUND ((XSize - NewXSize) / 2), ROUND ((YSize - NewYSize) / 2), 255);
0377: FreeImage_Save (opmC_BMPFormat, DIB5, PCHAR (DestName), 0);
0378: FINALLY
0379: FreeImage_Unload (DIB5);
0380: FreeImage_Unload (DIB6);
0381: DISPOSE (BackColor);
0382: END
0383: ELSE FreeImage_Save (opmC_BMPFormat, DIB4, PCHAR (DestName), 0);
0384: FNopm_ResizeImage2 := TRUE;
0385: FINALLY
0386: FreeImage_Unload (DIB2);
0387: FreeImage_Unload (DIB3);
0388: FreeImage_Unload (DIB4);
0389: END;
0390: END;
0391: FINALLY
0392: FreeImage_Unload (DIB1);
0393: END;
0394: END;
0395: END;
0396:
0397:
0398:
0399: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0400: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0401: FUNCTION FNopm_GetImgTempPath : STRING;
0402: VAR
0403: TmpDir : STRING;
0404: BufSize : DWORD;
0405: BEGIN
0406: SETLENGTH (TmpDir, MAX_PATH);
0407: BufSize := GetTempPath (MAX_PATH, PCHAR (TmpDir));
0408: SETLENGTH (TmpDir, BufSize);
0409: FNopm_GetImgTempPath := TmpDir;
0410: END;
0411:
0412:
0413: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0414: {%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
0415: PROCEDURE PRopm_AttachComment (VAR ImageDIB : FIBITMAP; CommentStr : STRING);
0416: VAR
0417: DIBTag : FITAG;
0418: CommentLen : LONGINT;
0419: CommentStrU : UTF8STRING;
0420: BEGIN
0421: DIBTag := NIL;
0422: CommentStrU := ANSITOUTF8 (CommentStr);
0423: CommentLen := SIZEOF (CommentStrU) + 1;
0424: IF (CommentStr <> '') THEN
0425: TRY
0426: DIBTag := FreeImage_CreateTag;
0427: IF (DIBTag <> NIL) THEN
0428: BEGIN
0429: FreeImage_SetTagKey (DIBTag, PCHAR ('Comment'));
0430: FreeImage_SetTagLength (DIBTag, CommentLen);
0431: FreeImage_SetTagCount (DIBTag, CommentLen);
0432: FreeImage_SetTagType (DIBTag, FIDT_ASCII);
0433: FreeImage_SetTagValue (DIBTag, PCHAR (CommentStr));
0434: FreeImage_SetMetadata (FIMD_COMMENTS, ImageDIB, FreeImage_GetTagKey (DIBTag), DIBTag);
0435: END;
0436: FINALLY
0437: FreeImage_DeleteTag (DIBTag);
0438: END;
0439: END;
0440:
0441:
0442: INITIALIZATION
0443:
0444: TPicture.RegisterFileFormat ('jpg', 'JPEG Image', opmT_GenericBitmap);
0445: TPicture.RegisterFileFormat ('png', 'PNG Image', opmT_GenericBitmap);
0446: TPicture.RegisterFileFormat ('tif', 'TIFF Image', opmT_GenericBitmap);
0447: TPicture.RegisterFileFormat ('pcx', 'PCX Image', opmT_GenericBitmap);
0448: TPicture.RegisterFileFormat ('gif', 'GIF Image', opmT_GenericBitmap);
0449: TPicture.RegisterFileFormat ('psd', 'Photoshop Image', opmT_GenericBitmap);
0450: TPicture.RegisterFileFormat ('tga', 'Targa Image', opmT_GenericBitmap);
0451: TPicture.RegisterFileFormat ('xbm', 'X11 Bitmap', opmT_GenericBitmap);
0452: TPicture.RegisterFileFormat ('xpm', 'X11 Pixmap', opmT_GenericBitmap);
0453:
0454: opmG_ImgTMPPath := FNopm_GetImgTempPath;
0455:
0456:
0457: FINALIZATION
0458:
0459: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpLoad_Filename);
0460: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpImg_Filename);
0461: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpBMP_Filename);
0462: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpJPG_Filename);
0463: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpPNG_Filename);
0464: SysUtils.DELETEFILE (opmG_ImgTMPPath + opmC_TmpGIF_Filename);
0465:
0466:
0467:
0468: END.
