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

質問

• ファイルをメモリに出力する方法について説明します。
• 配列をtiff画像ファイルに変換する方法について解説します。
• ファイル数が多い場合に時間がかかる問題を解決する方法を紹介します。

回答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