Save *.tiff images natively...

Got an idea for enhancing PureBasic? New command(s) you'd like to see?
Post Reply
User avatar
netmaestro
PureBasic Bullfrog
PureBasic Bullfrog
Posts: 8451
Joined: Wed Jul 06, 2005 5:42 am
Location: Fort Nelson, BC, Canada

Post by netmaestro »

On and Invalid Memory Access error, often the line that actually caused the error isn't highlighted, but the one following is. And sometimes it isn't highlighted until the ProcedureReturn line in a procedure. So a bit of sleuthing might be necessary.
BERESHEIT
Top
User avatar
netmaestro
PureBasic Bullfrog
PureBasic Bullfrog
Posts: 8451
Joined: Wed Jul 06, 2005 5:42 am
Location: Fort Nelson, BC, Canada

Post by netmaestro »

Here's a working version for PureBasic 4:

Code: Select all

#EncoderValueCompressionLZW = 2 
#EncoderValueCompressionCCITT3 = 3 
#EncoderValueCompressionCCITT4 = 4 
#EncoderValueCompressionRle = 5 
#EncoderValueCompressionNone = 6 
 
Structure ErrorCode 
  section.l 
  value.l 
EndStructure 

#WindowsError = 0 
#ImageViewerError = 1 
#GdiError = 2 

Procedure Error(message.s, *code.ErrorCode, fatal.b) 
  Select *code\section 
    Case #ImageViewerError 
      CodeMessage$ = "ImageViewer error: unknown" 
    Case #GdiError 
      Select *code\value 
        Case 0 
          ErrorBuffer$ = Space(1024) 
          FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, 0, GetLastError_(), 0, ErrorBuffer$, Len(ErrorBuffer$), 0) 
          CodeMessage$ = ErrorBuffer$ 
        Case 1 
          CodeMessage$ = "Generic error" 
        Case 2 
          CodeMessage$ = "Invalid parameter" 
        Case 3 
          CodeMessage$ = "Out of memory" 
        Case 4 
          CodeMessage$ = "Object busy" 
        Case 5 
          CodeMessage$ = "Insufficient buffer" 
        Case 6 
          CodeMessage$ = "Not implemented" 
        Case 7 
          ErrorBuffer$ = Space(1024) 
          FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, 0, GetLastError_(), 0, ErrorBuffer$, Len(ErrorBuffer$), 0) 
          CodeMessage$ = "Win32 Error: "+ErrorBuffer$ 
        Case 8 
          CodeMessage$ = "Wrong state" 
        Case 9 
          CodeMessage$ = "Aborted" 
        Case 10 
          CodeMessage$ = "File not found" 
        Case 11 
          CodeMessage$ = "Value overflow" 
        Case 12 
          CodeMessage$ = "Access denied" 
        Case 13 
          CodeMessage$ = "Unknown image format" 
        Case 14 
          CodeMessage$ = "Font family not found" 
        Case 15 
          CodeMessage$ = "Font style not found" 
        Case 16 
          CodeMessage$ = "Not TrueType font" 
        Case 17 
          CodeMessage$ = "Unsupported Gdiplus version" 
        Case 18 
          CodeMessage$ = "Gdiplus not initialized" 
        Case 19 
          CodeMessage$ = "Property not found" 
        Case 20 
          CodeMessage$ = "Property not supported" 
      EndSelect 
    Default 
      ErrorBuffer$ = Space(1024) 
      FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, 0, GetLastError_(), 0, ErrorBuffer$, Len(ErrorBuffer$), 0) 
      CodeMessage$ = ErrorBuffer$ 
  EndSelect 
  MessageRequester("Error", message+Chr(10)+Chr(10)+CodeMessage$, 0) 
  If fatal 
    End 
  EndIf 
EndProcedure 

Structure GdiplusStartupInput 
  GdiplusVersion.l 
  DebugEventCallback.l 
  SuppressBackgroundThread.l 
  SuppressExternalCodecs.l 
EndStructure 

; Structure CLSID 
;   Data1.l 
;   Data2.w[2] 
;   Data3.b[8] 
; EndStructure 

Structure MyGUID 
  Data1.l 
  Data2.w[2] 
  Data3.b[8] 
EndStructure 

Structure ImageCodecInfo 
  Clsid.CLSID         ; Codec identifier. 
  FormatID.MyGUID     ; File format identifier. GUIDs that identify various file formats (ImageFormatBMP, ImageFormatEMF, And the like) are defined in Gdiplusimaging.h. 
  CodecName.s         ; WCHAR * Pointer To a null-terminated string that contains the codec name. 
  DllName.s           ; WCHAR * Pointer To a null-terminated string that contains the path name of the DLL in which the codec resides. If the codec is not in a DLL, this pointer is NULL. 
  FormatDescription.s ; WCHAR * Pointer To a null-terminated string that contains the name of the file format used by the codec. 
  FilenameExtension.s ; WCHAR * Pointer To a null-terminated string that contains all file-name extensions associated with the codec. The extensions are separated by semicolons. 
  MimeType.s          ; WCHAR * Pointer To a null-terminated string that contains the mime type of the codec. 
  Flags.l             ; DWORD  Combination of flags from the ImageCodecFlags enumeration. 
  Version.l           ; DWORD  Integer that indicates the version of the codec. 
  SigCount.l          ; DWORD  Integer that indicates the number of signatures used by the file format associated with the codec. 
  SigSize.l           ; DWORD  Integer that indicates the number of bytes in each signature. 
  SigPattern.l        ; BYTE * Pointer To an array of bytes that contains the pattern For each signature. 
  SigMask.l           ; BYTE * Pointer To an array of bytes that contains the mask For each signature. 
EndStructure 

#EncoderParameterValueTypeLong = 4 

#EncoderValueCompressionLZW = 2 
#EncoderValueCompressionCCITT3 = 3 
#EncoderValueCompressionCCITT4 = 4 
#EncoderValueCompressionRle = 5 
#EncoderValueCompressionNone = 6 

Structure EncoderParameter 
  Guid.MyGUID 
  NumberOfValues.l 
  Type.l 
  Value.l 
EndStructure 

Structure EncoderParameters 
  Count.l 
  Parameter1.EncoderParameter 
;  Parameter2.EncoderParameter 
EndStructure 

Global Gdiplus, gdiplusToken, bitmap, hbmReturn, encoderClsid, width, height, num, size 
Global *GdiplusStartup, *GdiplusShutdown, *GdipSaveImageToFile, *GdipGetImageEncodersSize 
Global *GdipGetImageEncoders, *GdipCreateBitmapFromHBITMAP 

Procedure GdiStart() 
  Gdiplus = OpenLibrary(0, "GDIPLUS.DLL") 
  If Gdiplus 
    CoInitialize_(#Null) 
    *GdiplusStartup = GetFunction(0, "GdiplusStartup") 
    If *GdiplusStartup 
      gdpsi.GdiplusStartupInput 
      gdpsi\GdiplusVersion = 1 
      gdpsi\DebugEventCallback = 0 
      gdpsi\SuppressBackgroundThread = 0 
      gdpsi\SuppressExternalCodecs = 0 
      CallFunctionFast(*GdiplusStartup, @gdiplusToken, gdpsi, #Null) 
      If gdiplusToken 
        *GdipGetImageEncodersSize = GetFunction(0, "GdipGetImageEncodersSize") 
        *GdipGetImageEncoders = GetFunction(0, "GdipGetImageEncoders") 
        *GdipCreateBitmapFromHBITMAP = GetFunction(0, "GdipCreateBitmapFromHBITMAP") 
        *GdipSaveImageToFile = GetFunction(0, "GdipSaveImageToFile") 
        *GdiplusShutdown = GetFunction(0, "GdiplusShutdown") 
        If (*GdipGetImageEncodersSize And *GdipGetImageEncoders And *GdipCreateBitmapFromHBITMAP And *GdipSaveImageToFile And *GdiplusShutdown)=0 
          Gdiplus = 0 
        EndIf 
      Else 
        Gdiplus = 0 
      EndIf 
    Else 
      Gdiplus = 0 
    EndIf 
  Else 
    Gdiplus = 0 
  EndIf 
  ProcedureReturn Gdiplus 
EndProcedure 

Procedure GdiEnd() 
  If Gdiplus 
    CallFunctionFast(*GdiplusShutdown, gdiplusToken) 
    CoUninitialize_() 
  EndIf 
EndProcedure 

Procedure GetEncoderClsid(Format$, *Clsid) 
  Gerror.ErrorCode 
  result = 0 
  num = 0 
  size = 0 
  FormatWSize = (Len(Format$)*2)+2 
  *FormatW = CoTaskMemAlloc_(FormatWSize) 
  If *FormatW 
    If MultiByteToWideChar_(#CP_ACP, 0, @Format$, -1, *FormatW, Len(Format$)+1) 
      CallFunctionFast(*GdipGetImageEncodersSize, @num, @size) 
      If size 
        *ImageCodecInfoArray = CoTaskMemAlloc_(size) 
        If *ImageCodecInfoArray 
          result = CallFunctionFast(*GdipGetImageEncoders, num, size, *ImageCodecInfoArray) 
          If result=#S_OK 
            For j=0 To num-1 
              *pImageCodecInfo.ImageCodecInfo = *ImageCodecInfoArray+(SizeOf(ImageCodecInfo)*j);*ImageCodecInfoArray+((size/num)*j) 
              If CompareMemory(@*pImageCodecInfo\MimeType, *FormatW, FormatWSize) 
                PokeL(*Clsid, *pImageCodecInfo\Clsid) 
                result = j 
              EndIf 
            Next j 
          Else 
            ErrorMessage$ = "GdipGetImageEncoders() failed." 
          EndIf 
          CoTaskMemFree_(*pImageCodecInfo) 
        Else 
          Gerror\section = #WindowsError 
          Error("CoTaskMemAlloc_() failed.", Gerror, 0) 
        EndIf 
      Else 
        ErrorMessage$ = "GdipGetImageEncodersSize() failed." 
      EndIf 
    Else 
      Gerror\section = #WindowsError 
      Error("MultiByteToWideChar_() failed.", Gerror, 0) 
    EndIf 
    CoTaskMemFree_(*FormatW) 
  Else 
    Gerror\section = #WindowsError 
    Error("CoTaskMemAlloc_() failed.", Gerror, 0) 
  EndIf 
  If ErrorMessage$ 
    Gerror\section = #GdiError 
    Gerror\value = result 
    Error(ErrorMessage$, Gerror, 0) 
    result = 0 
  EndIf 
  ProcedureReturn result 
EndProcedure 

Procedure GdiSave(File$, hbm, compression) 
  Gerror.ErrorCode 
  If GetEncoderClsid("image/tiff", @encoderClsid) 
    FileWSize = (Len(File$)*2)+2 
    *FileW = CoTaskMemAlloc_(FileWSize) 
    If *FileW 
      If MultiByteToWideChar_(#CP_ACP, 0, File$, -1, *FileW, Len(File$)+1) 
        If hbm 
          eP.encoderParameters 
          encoderParams = eP 
          eP\Count = 1 ; 2 
          CopyMemory(?EncoderCompression, eP\Parameter1\Guid, SizeOf(MyGUID)) 
          eP\Parameter1\Type = #EncoderParameterValueTypeLong 
          eP\Parameter1\NumberOfValues = 1 
          eP\Parameter1\Value = @compression 
          bitmap = 0 
          result = CallFunctionFast(*GdipCreateBitmapFromHBITMAP, hbm, 0, @bitmap) 
          If result=#S_OK And bitmap 
            If FileSize(File$) 
              DeleteFile(File$) 
            EndIf 
            result = CallFunctionFast(*GdipSaveImageToFile, bitmap, *FileW, encoderClsid, encoderParams) 
            If result<>#S_OK 
              ErrorMessage$ = "GdipSaveImageToFile() failed." 
            EndIf 
          Else 
            ErrorMessage$ = "GdipCreateBitmapFromHBITMAP() failed." 
          EndIf 
        EndIf 
      Else 
        Gerror\section = #WindowsError 
        Error("MultiByteToWideChar_() failed.", Gerror, 0) 
      EndIf 
      CoTaskMemFree_(*FileW) 
    Else 
      Gerror\section = #WindowsError 
      Error("CoTaskMemAlloc_() failed.", Gerror, 0) 
    EndIf 
  Else 
    Gerror\section = #ImageViewerError 
    Error("GetEncoderCLSID() procedure failed.", Gerror, 0) 
  EndIf 
  If ErrorMessage$ 
    Gerror\section = #GdiError 
    Gerror\value = result 
    Error(ErrorMessage$, Gerror, 0) 
    result = 0 
  Else 
    result = 1 
  EndIf 
  ProcedureReturn result 
EndProcedure 

Structure Seeker 
  StructureUnion 
    b.b 
    w.w 
    l.l 
  EndStructureUnion 
EndStructure 

Procedure Rev16(value.w) 
  ProcedureReturn ((value&$FF00)>>8)|((value&$FF)<<8) 
EndProcedure 

Procedure Rev32(value) 
  MOV eax, value 
  BSWAP eax 
  ProcedureReturn 
EndProcedure 

Procedure SetTIFFResolution(file$, dpi) 
  Gerror.ErrorCode 
  hFile = OpenFile(#PB_Any, file$) 
  If hFile 
    TIFFSize = Lof(hFile) 
    If TIFFSize>$9A 
      *TIFF = AllocateMemory(Lof(hFile)) 
      ReadData(hFile, *TIFF, TIFFSize) 
      *TIFFSeek.Seeker = *TIFF 
      Select *TIFFSeek\w 
        Case 'MM' 
          dpi = Rev32(dpi) 
          *TIFFSeek+4 
          IFDOffset = Rev32(*TIFFSeek\l) 
          inch = Rev16(2) 
          den = Rev32(1) 
          rv = 1 
        Case 'II' 
          *TIFFSeek+4 
          IFDOffset = *TIFFSeek\l 
          inch = 2 
          den = 1 
          rv = 0 
        Default 
          Gerror\section = #ImageViewerError 
          Error("Not a TIFF file.", Gerror, 0) 
          CloseFile(hFile) 
          ProcedureReturn #False 
      EndSelect 
      *TIFFSeek = *TIFF+IFDOffset 
      If TIFFSize>IFDOffset+2 
        If rv:FieldCount = Rev16(*TIFFSeek\w):Else:FieldCount = *TIFFSeek\w:EndIf 
        If FieldCount 
          *TIFFSeek+2 
          For i=0 To FieldCount-1 
            If *TIFFSeek<*TIFF+TIFFSize-2 
              If rv:Tag = Rev16(*TIFFSeek\w):Else:Tag = *TIFFSeek\w:EndIf 
              Select Tag 
                Case 282 ; XResolution 
                  *TagSeek.Seeker = *TIFFSeek+8 
                  If rv:ValueOffset = Rev32(*TagSeek\l):Else:ValueOffset = *TagSeek\l:EndIf 
                  If ValueOffset<=TIFFSize-8 
                    PokeL(*TIFF+ValueOffset, dpi) 
                    PokeL(*TIFF+ValueOffset+4, den) 
                    xrelDone = 1 
                  EndIf 
                Case 283 ; YResolution 
                  *TagSeek = *TIFFSeek+8 
                  If rv:ValueOffset = Rev32(*TagSeek\l):Else:ValueOffset = *TagSeek\l:EndIf 
                  If ValueOffset<=TIFFSize-8 
                    PokeL(*TIFF+ValueOffset, dpi) 
                    PokeL(*TIFF+ValueOffset+4, den) 
                    yrelDone = 1 
                  EndIf 
                Case 296 ; ResolutionUnit 
                  PokeW(*TIFFSeek+8, inch) 
                  ruDone = 1 
              EndSelect 
              *TIFFSeek+12 
            EndIf 
          Next i 
        Else 
          Gerror\section = #ImageViewerError 
          Error("Field count not found.", Gerror, 0) 
        EndIf 
        If ruDone&yrelDone&xrelDone 
          FileSeek(hfile, 0) 
          WriteData(hFile,*TIFF, TIFFSize) 
          result = #True 
        Else 
          Gerror\section = #ImageViewerError 
          Error("Resolution fields not found.", Gerror, 0) 
        EndIf 
      Else 
        Gerror\section = #ImageViewerError 
        Error("Offset past end of file.", Gerror, 0) 
      EndIf 
    Else 
      Gerror\section = #ImageViewerError 
      Error("IFDOffset past end of file.", Gerror, 0) 
    EndIf 
    CloseFile(hFile) 
    ProcedureReturn result 
  Else 
    Gerror\section = #WindowsError 
    Error("Can't open file.", Gerror, 0) 
  EndIf 
  ProcedureReturn #False 
EndProcedure 

Procedure SaveTIFF(ImageID, file$, compression, dpi) 
  If GDISave(file$, ImageID, compression) 
    result = SetTIFFResolution(file$, dpi) 
  EndIf 
  ProcedureReturn result 
EndProcedure 

ImageFile$ = OpenFileRequester("Open image file", "", "Bitmap file (*.bmp)|*.bmp", 0) 
If ImageFile$ 
  hImage = LoadImage(0, ImageFile$) 
  TIFFFile$ = SaveFileRequester("Save TIFF file", Left(ImageFile$, Len(ImageFile$)-Len(GetExtensionPart(ImageFile$))-1)+".tiff", "TIFF image file (*.tiff;*.tif)|*.tiff;*.tif", 0) 
  If TIFFFile$ 
    If GdiStart() 
      compression = #EncoderValueCompressionLZW 
;        compression = #EncoderValueCompressionCCITT3 
;        compression = #EncoderValueCompressionCCITT4 
;        compression = #EncoderValueCompressionRle 
;        compression = #EncoderValueCompressionNone 
      dpi = 150 
      Debug SaveTIFF(hImage, TIFFFile$, compression, dpi) 
      GdiEnd() 
    EndIf 
  EndIf 
EndIf 

DataSection 
EncoderCompression: 
Data.l $e09d739d 
Data.w $ccd4, $44ee 
Data.b $8e, $ba, $3f, $bf, $8b, $e4, $fc, $58 
EndDataSection
BERESHEIT
Top
r_hyde
Enthusiast
Enthusiast
Posts: 155
Joined: Wed Jul 05, 2006 12:40 am

Post by r_hyde »

Well that probably saved me a few minutes:D Now, does anyone want to help me figure out why compression modes other than LZW are not working?
Top
User avatar
oryaaaaa
Addict
Addict
Posts: 825
Joined: Mon Jan 12, 2004 11:40 pm
Location: Okazaki, JAPAN

Re: Save *.tiff images natively...

Post by oryaaaaa »

Thanks.

I add Unicode/None executable code. works PB4.60(x86)

Procedure GetEncoderClsid(Format$, *Clsid)

Code: Select all

  *FormatW = CoTaskMemAlloc_(FormatWSize) 
  If *FormatW 
    CompilerIf #PB_Compiler_Unicode
    If PokeS(*FormatW, Format$, Len(Format$), #PB_Unicode)
    CompilerElse
    If MultiByteToWideChar_(#CP_ACP, 0, @Format$, -1, *FormatW, Len(Format$)+1)  
    CompilerEndIf
      CallFunctionFast(*GdipGetImageEncodersSize, @num, @Size) 
      If Size 
        *ImageCodecInfoArray = CoTaskMemAlloc_(Size) 
        If *ImageCodecInfoArray 
          result = CallFunctionFast(*GdipGetImageEncoders, num, Size, *ImageCodecInfoArray)
Procedure GdiSave(File$, hbm, compression)

Code: Select all

    FileWSize = (Len(File$)*2)+2 
    *FileW = CoTaskMemAlloc_(FileWSize) 
    If *FileW 
      CompilerIf #PB_Compiler_Unicode
      If PokeS(*FileW, File$, Len(File$), #PB_Unicode) 
      CompilerElse
      If MultiByteToWideChar_(#CP_ACP, 0, File$, -1, *FileW, Len(File$)+1)  
      CompilerEndIf
        If hbm 
          Protected eP.EncoderParameters 
          encoderParams = eP 
          eP\Count = 1 ; 2
Procedure SetTIFFResolution(File$, dpi)

Code: Select all

      Select *TIFFSeek\W 
        Case $7777
          dpi = Rev32(dpi) 
          *TIFFSeek+4 
          Protected IFDOffset = Rev32(*TIFFSeek\l) 
          Protected inch = Rev16(2) 
          Protected den = Rev32(1) 
          Protected rv = 1 
        Case $4949
          *TIFFSeek+4 
          IFDOffset = *TIFFSeek\l 
          inch = 2 
          den = 1 
          rv = 0 
        Default
Top
Post Reply

Return to “Feature Requests and Wishlists”