- Код: Выделить всё
'Tiff view solution, Example for PB
'Vladimir Shulakov
'sp@zdt.ru
'----------------------------------------------------
'compiler directives
#COMPILE EXE
#DIM ALL
#REGISTER NONE
#INCLUDE "WIN32API.INC"
$TIFFFile = "E:\1.tif"
'__________________________________________
'
TYPE TIF_HEADER
TIFFbyte AS INTEGER
version AS INTEGER
nPTR AS LONG
END TYPE
'__________________________________________
'
TYPE TIF_ENTRY
TIFFTag AS LONG
TypeX AS LONG
nLength AS LONG
nPTR AS LONG
END TYPE
'__________________________________________
'
%TIFFbyte = 1
%TIFFascii = 2
%TIFFshort = 3
%TIFFlong = 4
%TIFFrational = 5
%TIFFNewSubfile = 254
%TIFFSubfileType = 255
%TIFFImageWidth = 256
%TIFFImageLength = 257
%TIFFBitsPerSample = 258
%TIFFCompression = 259
%TIFFStripnPTRs = 273
%TIFFRowsPerStrip = 278
%TIFFStripByteCounts = 279
%TIFFSamplesPerPixel = 277
%TIFFPlanarConfiguration= 284
%TIFFGroup3Options = 292
%TIFFGroup4Options = 293
%TIFFFillOrder = 266
%TIFFThreshholding = 263
%TIFFCellWidth = 264
%TIFFCellLength = 265
%TIFFMinSampleValue = 280
%TIFFMaxSampleValue = 281
%TIFFPhotometricInterp = 262
%TIFFGrayResponseUnit = 290
%TIFFGrayResponseCurve = 291
%TIFFColorResponseUnit = 300
%TIFFColorResponseCurves= 301
%TIFFXResolution = 282
%TIFFYResolution = 283
%TIFFResolutionUnit = 296
%TIFFOrientation = 274
%TIFFDocumentName = 269
%TIFFPageName = 285
%TIFFXPosition = 286
%TIFFYPosition = 287
%TIFFPageNumber = 297
%TIFFImageDescription = 270
%TIFFMake = 271
%TIFFModel = 272
%TIFFFreenPTRs = 288
%TIFFFreeByteCounts = 289
%TIFFPredictor = 317
%TIFFtagPALETTE = 320
GLOBAL ImageData() AS RGBquad ' tiff image 32 bit data
GLOBAL TIFFBUFF() AS RGBtriple ' tiff file data, 24 bit data
GLOBAL FilePointer AS LONG
GLOBAL hdlg AS LONG
DECLARE FUNCTION getWord(BYVAL LONG,BYVAL LONG) AS LONG
DECLARE FUNCTION getLong(BYVAL LONG,BYVAL LONG) AS LONG
DECLARE FUNCTION ViewTIFF(FileName AS STRING, BYVAL hWnd AS LONG) AS LONG
'______________________________________________________________________________
'
FUNCTION nShl(BYVAL nVar AS LONG, BYVAL nShift AS LONG) AS LONG
! mov ecx,nShift
! shl nVar,cl
! mov eax,nVar
! mov FUNCTION,eax
END FUNCTION
'______________________________________________________________________________
'
FUNCTION nShr(BYVAL nVar AS LONG, BYVAL nShift AS LONG) AS LONG
! mov ecx,nShift
! shr nVar,cl
! mov eax,nVar
! mov FUNCTION,eax
END FUNCTION
'______________________________________________________________________________
'
CALLBACK FUNCTION hdlgproc() AS LONG
IF CBMSG = %WM_COMMAND THEN
CALL ViewTIFF ($TIFFFile, CBHNDL) ' load tiff
END IF
END FUNCTION
'______________________________________________________________________________
'
FUNCTION PBMAIN
DIM TIFFBUFF(1:1)
DIM ImageData(1:1)
DIALOG NEW 0&, "tiff view demo",,,400,300,%WS_SYSMENU TO hdlg
CONTROL ADD BUTTON, hdlg, 100,"load tiff", 5,5,40,15
DIALOG SHOW MODAL hdlg CALL hdlgproc
END FUNCTION
'______________________________________________________________________________
'
FUNCTION ViewTIFF(FileName AS STRING, BYVAL hWnd AS LONG) AS LONG
LOCAL nWidth AS LONG
LOCAL nHeight AS LONG
LOCAL i AS LONG
LOCAL k AS LONG
LOCAL j AS LONG
LOCAL entry AS LONG
LOCAL tif_head AS TIF_HEADER
LOCAL tifen AS TIF_ENTRY
LOCAL BmTiff AS BITMAPINFO
LOCAL TiffReady AS LONG
LOCAL Temp AS LONG
LOCAL TIFFSpec AS LONG
LOCAL nPTR AS LONG
LOCAL nPTR1 AS LONG
LOCAL nPTR2 AS LONG
LOCAL x AS LONG
ON ERROR GOTO ErrorSolution
FUNCTION = %FALSE
FilePointer = 1&
OPEN FileName FOR BINARY ACCESS READ AS #1&
i = getWord(1, %TRUE)
IF i = &h4949 THEN
TIFFSpec = %TRUE
ELSEIF i = &h4D4D THEN
TIFFSpec = %FALSE
ELSE
CLOSE #1&
EXIT FUNCTION
END IF
tif_head.version = getWord(1, TIFFSpec)
IF tif_head.version <> 42 THEN
CLOSE #1
EXIT FUNCTION
END IF
tif_head.nPTR = getLong(1, TIFFSpec)
nPTR1 = tif_head.nPTR
FilePointer = nPTR1 + 1&
entry = getWord(1, TIFFSpec)
FOR i = 0& TO entry - 1&
tifen.TIFFTag = getWord(1&, TIFFSpec)
tifen.TypeX = getWord(1&, TIFFSpec)
IF tifen.TypeX = %TIFFlong THEN
tifen.nLength = getLong(1&, TIFFSpec)
tifen.nPTR = getLong(1&, TIFFSpec)
ELSE
tifen.nLength = getWord(1&, TIFFSpec)
getWord 1, TIFFSpec
tifen.nPTR = getWord(1&, TIFFSpec)
Temp = getWord(1&, TIFFSpec)
END IF
SELECT CASE tifen.TIFFTag
CASE %TIFFSubfileType, %TIFFCompression, %TIFFPlanarConfiguration
IF tifen.nPTR <> 1 THEN
CLOSE #1
EXIT FUNCTION
END IF
CASE %TIFFImageWidth
nWidth = tifen.nPTR
CASE %TIFFImageLength
nHeight = tifen.nPTR
CASE %TIFFBitsPerSample
IF tifen.nLength <> 3 THEN
CLOSE #1
EXIT FUNCTION
END IF
CASE %TIFFPhotometricInterp
Temp = tifen.nPTR
IF (Temp <> 2&) AND (Temp <> 3&) AND (Temp <> 1&) THEN TiffReady = 1&
CASE %TIFFStripnPTRs
nPTR2 = tifen.nPTR
END SELECT
NEXT i
IF nWidth = 0& OR nHeight = 0& THEN
CLOSE #1
EXIT FUNCTION
END IF
REDIM ImageData(nWidth * (nHeight+4&))
REDIM TIFFBUFF(0& TO nWidth-1&)'
IF TiffReady = 0& THEN
FilePointer = nPTR2 + 1&
nPTR = 0&
FOR i = 0& TO nHeight - 1&
GET #1, FilePointer, TIFFBUFF()
FilePointer = FilePointer + (nWidth * 3&)
! mov x,1&
FOR j = 0& TO nWidth - 1&
ImageData(nPTR).rgbblue = TIFFBUFF(x).rgbtred
ImageData(nPTR).rgbgreen = TIFFBUFF(x).rgbtgreen
ImageData(nPTR).rgbred = TIFFBUFF(x).rgbtblue
! inc x
! inc nPTR
NEXT j
NEXT i
END IF
CLOSE #1
'************************************************************************
BmTiff.bmiHeader.biSize = 40
BmTiff.bmiHeader.biWidth = nWidth
BmTiff.bmiHeader.biHeight = nHeight
BmTiff.bmiHeader.biPlanes = 1
BmTiff.bmiHeader.biCompression = %BI_RGB
BmTiff.bmiHeader.biBitCount = 32
LOCAL hdc AS LONG
hdc = getdc(hwnd)
SetStretchBltMode hdc, %Halftone
StretchDIBits hdc, 0, 0, 595, 459, 0, 0, nWidth, nHeight, BYVAL VARPTR(ImageData(0)), BmTiff, %DIB_RGB_COLORS,%SrcCopy
ReleaseDC hWnd,hDC
FUNCTION = %TRUE
EXIT FUNCTION
ErrorSolution:
ERRCLEAR
CLOSE #1
FUNCTION = %FALSE
END FUNCTION
'___________________________________________________________________________
'
FUNCTION getWord(BYVAL fn AS LONG,BYVAL TIFFSpec AS LONG) AS LONG
#REGISTER NONE
LOCAL a AS STRING
GET$ fn,2,a
IF TIFFSpec = %TRUE THEN
FUNCTION = CVWRD(a)
ELSE
FUNCTION = CVWRD(STRREVERSE$(a))
END IF
END FUNCTION
'_________________________________________________________________________________
'
FUNCTION getLong(BYVAL fn AS LONG, BYVAL TIFFSpec AS LONG) AS LONG
#REGISTER NONE
LOCAL a AS STRING
GET$ fn,4,a
IF TIFFSpec = %TRUE THEN
FUNCTION = CVL(a)
ELSE
FUNCTION = CVL(STRREVERSE$(a))
END IF
END FUNCTION