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.
 
 
NA fum/lmd: 2007.07.15
Copyright ©1994-2017 by Mario A. Valdez-Ramírez.
no siga este enlace / do not follow this link