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

質問

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

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

http://okwave.jp/qa/q8809275.html

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

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

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

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

回答No.4

mitarashi · ベストアンサー

#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

お礼

ありがとうございます。

RGBの場合にはうまくいきました。

あと、アルファチャンネルも使いたいので

Sub test4()

' Dim myA As Long, myR As Long, myG As Long, myB As Long, myRGB As Long
Dim myA As Double, myR As Double, myG As Double, myB As Double, myRGB As Double

'Byte型だとmyR * &H10000のところでオーバーフロー

myA = 255
myR = 255
myG = 255
myB = 255
myRGB = myA * &H1000000 + myR * &H10000 + myG * &H100 + myB
Debug.Print Hex(myRGB) '->FFFFFF
End Sub

のようにしてみたのですが、
myA * &H1000000　のところでオーバーフローしてしまいます。

どのようにすれば良いでしょうか？

回答No.3

mitarashi

#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

お礼

ありがとうございます。

とりあえず
Excelのシートからtiff画像を出力できることは確認できました。

配列に関しても

Dim AI() As Byte
Dim AI2() As Long

ReDim AI(lngWidth, lngHeight, 3)
ReDim AI2(lngWidth, lngHeight)

For y = 0 To lngHeight - 1
For x = 0 To lngWidth - 1

AI(x, y, 1) = 55
AI(x, y, 2) = 155
AI(x, y, 3) = 255

Next x
Next y

For y = 0 To lngHeight - 1
For x = 0 To lngWidth - 1

AI2(x, y) = AI(x, y, 1) & AI(x, y, 2) & AI(x, y, 3)

Next x
Next y

For y = 0 To lngHeight - 1
For x = 0 To lngWidth - 1
' BGR→ARGB

myARGB = &HFF000000 Or AI2(x, y)

'セル色をARGBに変換して、オンメモリの画像に設定
GdipBitmapSetPixel pDstBitmap, x, y, myARGB
Next x
Next y

のようにすると、画像を出力することができました。

ただ、いったいどういう

AI(x, y, 1) = 55
AI(x, y, 2) = 155
AI(x, y, 3) = 255

のところがRGBの設定になっているはずなのですが
255,255,255にしても白色になりませんし、
思ったような色にならないのですが。

Hexを使って16進数に変えてみてもうまくいきませんでした。

どうすれば良いでしょうか？

補足

http://www.mrexcel.com/forum/excel-questions/801345-color-cell-rgba-color-visual-basic-applications-code.html

このページを参考にするとできました。

ありがとうございます。

回答No.2

mitarashi

#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

回答No.1

mitarashi

そのままズバリの回答ではありませんが、ご参考に、エクセルのセルにつけた色を画像として保存するコードです。
セルからの色取得の部分を、配列に納めた色取得に置き換えれば転用可能と思います。
また、この例では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