GDIplusCODE


Type myRGB
    red As Long
    green As Long
    blue As Long
End Type

Sub convertCellToImage()
    Dim clGdip As ClGdiPlus
    Dim retBool As Boolean
    ' ピクセル色成分を受け取る配列
    Dim lPixels() As Byte
    ' カウンタ
    Dim lCptX As Long, lCptY As Long
    Dim xoffset As Long, yoffset As Long
    Dim myCellColor As myRGB
    Dim destfile As String
    Dim ImageWidth As Long, ImageHeight As Long
    Dim vntFileName As Variant
    Dim pictType As String
    Const jpegQuality As Long = 90
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    ImageWidth = Selection.Columns.Count
    ImageHeight = Selection.Rows.Count
    xoffset = Selection.Cells(1).Column - 1
    yoffset = Selection.Cells(1).Row - 1
    'ファイルを保存するダイアログを開きます
    vntFileName = _
        Application.GetSaveAsFilename(InitialFileName:="picture.jpg" _
           , FileFilter:="画像ファイル,*.jpg;*.bmp;*.png" _
           , FilterIndex:=1 _
           , Title:="保存先の指定" _
           )
    If vntFileName <> False Then
        Select Case StrConv(Right(vntFileName, 3), vbUpperCase)
        Case "JPG"
            pictType = "JPG"
        Case "BMP"
            pictType = "BMP"
        Case "PNG"
            pictType = "PNG"
        Case Else
            MsgBox "サポートされていない画像形式です"
            Exit Sub
        End Select
        destfile = vntFileName
    Else
        Exit Sub
    End If

    Set clGdip = New ClGdiPlus
    ' 新しいビットマップを作成 幅、高さ、解像度（デフォルト96)
    retBool = clGdip.CreateBitmap(ImageWidth, ImageHeight, 96)
    ' ピクセル色成分を配列に設定
    lPixels = clGdip.GetPixels
    ' ピクセル単位でループ
    For lCptX = 0 To UBound(lPixels(), 2)
        For lCptY = 0 To UBound(lPixels(), 3)
            myCellColor = getIndexColor(Cells(lCptY + yoffset + 1, lCptX + xoffset + 1).Interior.ColorIndex)
            With myCellColor
                lPixels(1, lCptX, lCptY) = .blue
                lPixels(2, lCptX, lCptY) = .green
                lPixels(3, lCptX, lCptY) = .red
                lPixels(4, lCptX, lCptY) = &HFF
            End With
        Next lCptY
    Next lCptX
'    ' 画像の色成分を設定
    clGdip.SetPixels lPixels
    If pictType = "JPG" Then
        retBool = clGdip.SaveFile(destfile, "JPG", jpegQuality)
    Else
        retBool = clGdip.SaveFile(destfile, pictType)
    End If
    Set clGdip = Nothing
End Sub

'http://pygj.cocolog-nifty.com/mukago/excel_vba/index.htmlをお借りしています
Private Function getIndexColor(myColorIndex As Long) As myRGB
    Dim ColorHex As String 'Colorプロパティの値を16進数で格納
    Dim j
    
    If myColorIndex = xlNone Then
      ColorHex = "FFFFFF"
    Else
      ColorHex = Hex(ActiveWorkbook.Colors(myColorIndex))
    End If
    For j = 0 To 5 - Len(ColorHex)
        ColorHex = "0" & ColorHex
    Next
    With getIndexColor
    .blue = CLng("&H" & Left(ColorHex, 2))
    .green = CLng("&H" & Right(Left(ColorHex, 4), 2))
    .red = CLng("&H" & Right(ColorHex, 2))
    End With
End Function
選択範囲のセルを画像に書き出し

修正しました
