TIFF多页-无颜色！ [英] Tiff multipage - no color!

问题描述

我一直在使用这段代码多页Tiff ，谢谢bijulsoni！

我想尝试制作彩色图像，我试图理解该概念，但是缺少一些东西.我已经阅读了鲍勃·鲍威尔(Bob Powells)关于锁位的工作.无论如何，这里是我无法正常工作的版本:

I have been playing with this code Multipage Tiff, Thanks bijulsoni!

I want to try and make a color image, I am trying to understand the concept, but missing something. I have read Bob Powells work on lockbits. Anyway here my not working version:

Private Function ConvertToBitonalClr(ByVal original As Bitmap) As Bitmap
    Dim source As Bitmap = Nothing
    ' If original bitmap is not already in 32 BPP, ARGB format, then convert
    If original.PixelFormat <> PixelFormat.Format32bppArgb Then
      source = New Bitmap(original.Width, original.Height, PixelFormat.Format32bppArgb)
      source.SetResolution(original.HorizontalResolution, original.VerticalResolution)
      Using g As Graphics = Graphics.FromImage(source)
        g.DrawImageUnscaled(original, 0, 0)
      End Using
    Else
      source = original
    End If
    ' Lock source bitmap in memory
    Dim sourceData As BitmapData = source.LockBits(New Rectangle(0, 0, source.Width, source.Height), ImageLockMode.[ReadOnly], PixelFormat.Format32bppArgb)
    ' Copy image data to binary array
    Dim imageSize As Integer = sourceData.Stride * sourceData.Height
    Dim sourceBuffer As Byte() = New Byte(imageSize - 1) {}
    Marshal.Copy(sourceData.Scan0, sourceBuffer, 0, imageSize)
    ' Unlock source bitmap
    source.UnlockBits(sourceData)
    ' Create destination bitmap
    Dim destination As New Bitmap(source.Width, source.Height, PixelFormat.Format24bppRgb)
    ' Lock destination bitmap in memory
    Dim destinationData As BitmapData = destination.LockBits(New Rectangle(0, 0, destination.Width, destination.Height), ImageLockMode.[WriteOnly], PixelFormat.Format1bppIndexed)
    ' Create destination buffer
    imageSize = destinationData.Stride * destinationData.Height
    Dim destinationBuffer As Byte() = New Byte(imageSize - 1) {}
    Dim sourceIndex As Integer = 0
    Dim destinationIndex As Integer = 0
    Dim pixelTotal As Integer = 0
    Dim destinationValue As Byte = 0
    Dim height As Integer = source.Height
    Dim width As Integer = source.Width
    ' Iterate lines
    For y As Integer = 0 To height - 1
      sourceIndex = y * sourceData.Stride
      destinationIndex = y * destinationData.Stride
      destinationValue = 0
      ' Iterate pixels
      For x As Integer = 0 To width - 1
        Dim b As Integer = sourceBuffer(sourceIndex)
        Dim g As Integer = sourceBuffer(sourceIndex + 1)
        Dim r As Integer = sourceBuffer(sourceIndex + 2)
        'this is me thinking it would be this simple =)
        destinationBuffer(destinationIndex + 1) = b
        destinationBuffer(destinationIndex + 2) = g
        destinationBuffer(destinationIndex + 3) = r
        sourceIndex += 4
      Next
    Next
    ' Copy binary image data to destination bitmap
    Marshal.Copy(destinationBuffer, 0, destinationData.Scan0, imageSize)
    ' Unlock destination bitmap
    destination.UnlockBits(destinationData)
    ' Return
    Return destination
  End Function

感谢您的观看并向正确的方向提供了帮助.

Thanks for looking and some help in the right direction.

推荐答案

为什么没有destinationIndex += 3吗?

您也可以通过直接索引destinationData.Scan0而无需中间destinationBuffer.

以及为什么New Byte(imageSize<big> - 1</big>) ???

Why no destinationIndex += 3 ?

You could also work without an intermediate destinationBuffer, by directly indexing destinationData.Scan0.

And why New Byte(imageSize<big> - 1</big>) ???

这是我的解决方案！

Here is my solution!

<pre lang="vb">Private Sub SaveImages(ByVal imgs() As Image, ByVal filepath As String)
  ''get the codec
  Dim info As ImageCodecInfo = Nothing
  For Each ici As ImageCodecInfo In ImageCodecInfo.GetImageEncoders()
    If ici.MimeType = "image/tiff" Then
      info = ici
    End If
  Next
  Dim enc As Imaging.Encoder = Imaging.Encoder.SaveFlag
  Dim ep As New EncoderParameters(1)
  ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.MultiFrame))
  Dim pages As Bitmap = Nothing
  Dim frame As Integer = 0
  For Each img As Image In images
    If frame = 0 Then
      pages = DirectCast(img, Bitmap)
      ''save first
      pages.Save(filepath, info, ep)
    Else
      ''save next
      ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.FrameDimensionPage))
      Dim bm As Bitmap = DirectCast(img, Bitmap)
      pages.SaveAdd(bm, ep)
    End If
    If frame = images.Count - 1 Then
      ''close.
      ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.Flush))
      pages.SaveAdd(ep)
    End If
    frame += 1
  Next
End Sub

这篇关于TIFF多页-无颜色！的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！