CANDERA開発者コラム
「第10回  VBAのテクスチャ描画システムを拡張する(1)」

Public Type SWImageDraw
  id As Integer
  imageID As Integer
  pos As Position
End Type

Sub SetupImage(ByRef aImage() As SWImage)
  ' まずはimageシートの有効な行の数を調べる.
  Dim nRowCnt As Integer
  Dim nElementCnt As Integer

  Dim nRows As Integer
  With Worksheets("image")
    nRows = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
  End With

  ReDim aImage(nRows - 1)

  For nRowCnt = 2 To 2 + nRows - 1
    With Worksheets("image")
      ' 1列目が管理番号.
      aImage(nElementCnt).id = .Cells(nRowCnt, 1).Value

      ' 2列目はファイル名なので、ここで画像の読み込み処理をコール.
      Call LoadImage(aImage(nElementCnt).image, ThisWorkbook.Path & PATH_DELIMITER & .Cells(nRowCnt, 2).Value)
        
      nElementCnt = nElementCnt + 1
    End With
  Next

End Sub
Sub SetupImageDraw(ByRef aImageDraw() As SWImageDraw)
  ' まずはimagedrawシートの有効な行の数を調べる.
  Dim nRowCnt As Integer
  Dim nElementCnt As Integer

  Dim nRows As Integer
  With Worksheets("imagedraw")
    nRows = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
  End With

  ReDim aImageDraw(nRows - 1)

  For nRowCnt = 2 To 2 + nRows - 1
    With Worksheets("imagedraw")
      ' 1列目は管理番号.
      aImageDraw(nElementCnt).id = .Cells(nRowCnt, 1).Value

      ' 2列目はImageID.
      aImageDraw(nElementCnt).imageID = .Cells(nRowCnt, 2).Value

      ' 3列目からは座標.
      aImageDraw(nElementCnt).pos.x = .Cells(nRowCnt, 3).Value
      aImageDraw(nElementCnt).pos.y = .Cells(nRowCnt, 4).Value

      nElementCnt = nElementCnt + 1
    End With
  Next nRowCnt

End Sub

Sub DrawImage(ByRef pos As Position, ByRef rImageStructure As SWImageStructure)
  ' rImageStructure.dataの内容をコピーする.
  Dim nRowStart As Long
  Dim nColStart As Long

  ' カウンタ変数を用意.
  Dim nRowCnt As Long: nRowCnt = 0
  Dim nColCnt As Long: nColCnt = 0

  ' 読み込んだ画像データ上のピクセルの開始位置.
  Dim nPixelPosition As Long: nPixelPosition = 0

  ' 色を一時的に格納する変数.
  Dim sColor As ColorRGB

  ' ピクセル辺り何Bytesか( デフォルトは4 ).
  Dim nBytesPerPixel As Integer: nBytesPerPixel = 4

  ' ただし、画像フォーマットが0番の場合は3.
  If IMAGE_FORMAT_TYPE_RGB = rImageStructure.format Then
    nBytesPerPixel = 3
  End If

  nRowStart = pos.y + 1
  nColStart = pos.x + 1

  With Worksheets("framebuffer")
    ' 幅( 列 )を塗りきったら改行.
    For nRowCnt = 0 To rImageStructure.height - 1
      For nColCnt = 0 To rImageStructure.width - 1
        ' 読み込んだ画像データ上の位置.
        nPixelPosition = nBytesPerPixel * (nColCnt + nRowCnt * rImageStructure.width)

        ' この形式では色はRGB(A)の順番で格納されている.
        ' まだアルファチャネルは考慮しない.
        sColor.R = rImageStructure.data(nPixelPosition)
        sColor.G = rImageStructure.data(nPixelPosition + 1)
        sColor.B = rImageStructure.data(nPixelPosition + 2)
        .Cells(nRowStart + nRowCnt, nColStart + nColCnt).Interior.color = RGB(sColor.R, sColor.G, sColor.B)
      Next nColCnt
    Next nRowCnt
  End With
End Sub

Sub Main()
  Dim cRenderSystem As RenderingSystem
  Set cRenderSystem = New RenderingSystem

  ' Rectの格納場所を用意.
  Dim aRect() As Rect
  Dim nCnt As Integer

  ' imageの格納場所を用意.
  Dim aImage() As SWImage

  ' imagedrawの格納場所を用意.
  Dim aImageDraw() As SWImageDraw

  ' 初期化処理をコール.
  Call Initialize(cRenderSystem)

  ' rectシートから、Rectをセットアップ.
  Call SetupRect(aRect)

  ' imageシートから、SWImageをセットアップ.
  Call SetupImage(aImage)

  ' imagedrawシートから、SWImageDrawをセットアップ.
  Call SetupImageDraw(aImageDraw)

  ' aRectの要素数に合わせてRenderingSystemのDrawRectをコール.
  For nCnt = LBound(aRect) To UBound(aRect)
    Call cRenderSystem.DrawRect(aRect(nCnt))
  Next

  ' aImageの要素数に合わせてRenderingSystemのDrawImageをコール.
  For nCnt = LBound(aImageDraw) To UBound(aImageDraw)
    Call cRenderSystem.DrawImage(aImageDraw(nCnt).pos, aImage(aImageDraw(nCnt).imageID).image)
  Next

  ' 終了処理をコール.
  Call Terminate(cRenderSystem)
End Sub