ファイルをメモリに出力する方法

Question

ある配列をtiff画像ファイルとして出力したいのですが

配列を一度bmp画像ファイルとして出力して

http://oshiete.goo.ne.jp/qa/8809275.html

このページにある方法を使って、それをtiffファイルに変換して
残ったbmpファイルを削除するというプログラムを作りました。

この方法だと、HDDにアクセスする手順が多くなるため、ファイル数が多い時に時間がかかってしまいます。

bmpファイルをメモリにいったん保存しておいて、
それをtiffファイルに書き換えるようなプログラムを作るにはどうしたら良いですか？

あるいは配列から直接tiff画像ファイルを出力する方法があれば
教えてください。

mitarashi · Accepted Answer

#1-3です。
型変換をVBAに頼り過ぎだと存じます。
真面目にやるべきでしょう。
簡単な例で試してみました。ご参考まで。

Sub test()
  Dim myR As Byte, myG As Byte, myB As Byte
  Dim myRGB As Long
  myR = 255
  myG = 255
  myB = 255
  myRGB = myR & myG & myB
  Debug.Print Hex(myRGB) '->F36E2D7　白にならない
End Sub

Sub test2()
  Dim myR As Byte, myG As Byte, myB As Byte
  Dim myRGB As Long
  myR = 255
  myG = 255
  myB = 255
  myRGB = CLng("&H" & Hex(myR) & Hex(myG) & Hex(myB))
  Debug.Print Hex(myRGB) '-> FFFFFF
End Sub

Sub test3()
  Dim myR As Long, myG As Long, myB As Long 'Byte型だとmyR * &H10000のところでオーバーフロー
  Dim myRGB As Long
  myR = 255
  myG = 255
  myB = 255
  myRGB = myR * &H10000 + myG * &H100 + myB
  Debug.Print Hex(myRGB) '->FFFFFF
End Sub

mitarashi · Answer

#1です。TIFF保存をやってみました。BGR->ARGBも速いかもしれない方法に変更してあります。ご参考まで。
（API宣言等は省略します）
Sub saveCellColorTIFF()
  Dim strOutName As String
  Dim lngWidth As Long
  Dim lngHeight As Long
  Dim lngResult As Long
  Dim lngGDIPToken As Long
  Dim pSrcBitmap As Long
  Dim pDstBitmap As Long
  Dim udtEncParam As EncoderParameters
  Dim udtGdiPlus As GdiplusStartupInput
  Dim encTIFF As UUID
  Dim x As Long, y As Long
  Dim myARGB As Long
  Dim myColor As Long, newColor As Long
  
  strOutName = GetDesktopPath & "\" & "test.tif"
    
  lngHeight = 100
  lngWidth = 200

'GDI+を使う準備をする
    udtGdiPlus.GdiplusVersion = 1
    If GdiplusStartup(lngGDIPToken, udtGdiPlus, 0&) <> 0 Then
        Exit Sub
    End If
     
'設定したセルの色を逆に画像ファイルに書き出し
    'メモリ上に読み込んだ画像と同じサイズのbitmapオブジェクトを生成
    lngResult = GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDstBitmap)
    
    For y = 0 To lngHeight - 1
      For x = 0 To lngWidth - 1
'        BGR→ARGB
        myColor = ActiveSheet.Cells(y + 1, x + 1).Interior.color
        newColor = (myColor And &HFF&) * &H10000 Or _
                    ((myColor \ &H100&) And &HFF&) * &H100& Or _
                    ((myColor \ &H10000) And &HFF&)
        myARGB = &HFF000000 Or newColor
        
        'セル色をARGBに変換して、オンメモリの画像に設定
        GdipBitmapSetPixel pDstBitmap, x, y, myARGB
      Next x
    Next y
    
    'TIFF形式で保存　出典http://tanlab.blog.fc2.com/blog-entry-31.html
    udtEncParam.Count = 1
    With udtEncParam.Parameter(0)
        CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .Guid ' 圧縮方法
        .NumberOfValues = 1
        .Type = 4
        .Value = VarPtr(2) ' 画像圧縮:LZW=2, CCITT3=3, CCITT4=4, Rle=5, None=6
    End With

'-- TIFFエンコーダのCLSID
    CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), encTIFF
'-- TIFF保存
    GdipSaveImageToFile pDstBitmap, StrPtr(strOutName), encTIFF, VarPtr(udtEncParam)
    
    GdipDisposeImage pDstBitmap
    GdipDisposeImage pSrcBitmap
    Call GdiplusShutdown(lngGDIPToken)
End Sub

mitarashi · Answer

#1の続き、プログラム本体です。
以上、ご参考まで。

Sub saveCellColor()
    Dim strOutName As String
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim Quality As Long
    Dim lngResult As Long
    Dim lngGDIPToken As Long
    Dim pSrcBitmap As Long
    Dim pDstBitmap As Long
    Dim udtEncParam As EncoderParameters
    Dim udtGdiPlus As GdiplusStartupInput
    
    Dim x As Long, y As Long
    Dim myARGB As Long
    Dim strARGB As String
    Dim strBGR As String

Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
    Const CLSID_QUALITY = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Quality = 90
    strOutName = GetDesktopPath & "\" & "test.jpg"
  lngHeight = 100
  lngWidth = 200

'GDI+を使う準備をする
    udtGdiPlus.GdiplusVersion = 1
    If GdiplusStartup(lngGDIPToken, udtGdiPlus, 0&) <> 0 Then
        Exit Sub
    End If
     
'セルの色を画像ファイルに書き出し
    '指定サイズのbitmapオブジェクトを生成
    lngResult = GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDstBitmap)
    
    For y = 0 To lngHeight - 1
      For x = 0 To lngWidth - 1
        strBGR = Hex(ActiveSheet.Cells(y + 1, x + 1).Interior.color)
        'セル色を文字列に変換するが、規定のバイト数を保持しないと、色が化けてしまう
        strBGR = Right("000000" & strBGR, 6)
        myARGB = CLng("&H" & "FF" & Mid(strBGR, 5, 2) & Mid(strBGR, 3, 2) & Mid(strBGR, 1, 2))
        'セル色をARGBに変換して、オンメモリの画像に設定
        GdipBitmapSetPixel pDstBitmap, x, y, myARGB
      Next x
    Next y
    
    ' JPG変換で保存
    udtEncParam.Count = 1
    With udtEncParam.Parameter(0)
        .Guid = GetCLSID(CLSID_QUALITY)
        .NumberOfValues = 1
        .Type = 4
        .Value = VarPtr(Quality)
    End With
    Call GdipSaveImageToFile(pDstBitmap, StrPtr(strOutName), GetCLSID(CLSID_JPEG), VarPtr(udtEncParam))
    GdipDisposeImage pDstBitmap
    GdipDisposeImage pSrcBitmap
    Call GdiplusShutdown(lngGDIPToken)
End Sub

mitarashi · Answer

そのままズバリの回答ではありませんが、ご参考に、エクセルのセルにつけた色を画像として保存するコードです。
セルからの色取得の部分を、配列に納めた色取得に置き換えれば転用可能と思います。
また、この例ではJPEG保存ですが、ご質問文中のURLをご参考にTIFF保存に改造可能と思います。
GDI+を使い、色の置き換えを文字列処理でやったりしていますので、御期待ほど速くなるかは不明です。
長いので二回に分けます。本体は続報で載せます。

Private Type UUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    Guid As UUID
    NumberOfValues As Long
    Type As Long
    Value As Long
End Type
Private Type EncoderParameters
    Count As Long
    Parameter(15) As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "gdiplus.dll" (ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" (ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" (ByVal image As Long, ByVal fileName As Long, ByRef clsidEncoder As UUID, ByVal encoderParams As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszCLSID As Long, ByRef pclsid As UUID) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (fileName As Any, bitmap As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As Long
Private Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, ByVal color As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long

Const PixelFormat32bppARGB = &H26200A

Private Function GetCLSID(ByVal strGuid As String) As UUID
Dim lngResult As Long
    lngResult = CLSIDFromString(StrPtr(strGuid), GetCLSID)
End Function

'テスト用
Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function

ファイルをメモリに出力する方法

#1-3です。

#1です。

この回答への補足

#1の続き、プログラム本体です。

そのままズバリの回答ではありませんが、ご参考に、エクセルのセルにつけた色を画像として保存するコードです。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング