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