vbsの作法 その20

概要

vbsの作法調べてみた。
bmpファイル作ってみた。

写真

サンプルコード

Dim objPALT
Dim objPALTImage
ForWriting = 2
Set objPALT = New Palette
objPALT.SetProperties 16, 5
objPALT.SetColor 0, 0, 0, 0, 0
objPALT.SetColor 1, 215, 215, 215, 0
objPALT.SetColor 3, 255, 255, 255, 0
Set objPALTImage = New Image
objPALTImage.SetProperties 256, 256, 8
For i = 0 To 256
    For j = 0 To 256
        if (i - 128) * (i - 128) + (j - 128) * (j - 128) < 5000 Then
            objPALTImage.SetPixel i, j, 15
        End if
    Next
Next
objPALTImage.ExportToBMP "C:\test.bmp", objPALT
msgbox "ok"



Class StringBuilder
    Dim arr
    Dim growthRate
    Dim itemCount
    Private Sub Class_Initialize()
        growthRate = 50
        itemCount = 0
        ReDim arr(growthRate)
    End Sub
    Public Sub Append(ByVal strValue)
        If itemCount > UBound(arr) Then
            ReDim Preserve arr(UBound(arr) + growthRate)
        End If
        arr(itemCount) = strValue
        itemCount = itemCount + 1
    End Sub
    Public Function ToString()
        ToString = Join(arr, "")
    End Function
End Class

Class Palette
    Private intNumberOfColors
    Private intBitsPerComponent
    Private arrData()
    Private Sub Class_Initialize()
        intNumberOfColors = 0
        intBitsPerComponent = 0
    End Sub
    Public Function SetProperties(pintNumberOfColors, pintBitsPerComponent)
        intNumberOfColors = pintNumberOfColors
        intBitsPerComponent = pintBitsPerComponent
        ReDim arrData(pintNumberOfColors - 1, 3)
        Randomize 314159265
        Dim intIndex
        For intIndex = 0 To pintNumberOfColors - 1
            Int(Rnd * (2^pintBitsPerComponent))
            arrData(intIndex, 0) = Int(Rnd * (2 ^ pintBitsPerComponent))
            arrData(intIndex, 1) = Int(Rnd * (2 ^ pintBitsPerComponent))
            arrData(intIndex, 2) = Int(Rnd * (2 ^ pintBitsPerComponent))
            arrData(intIndex, 3) = 0
        Next
    End Function
    Public Function SetColor(pintColorIndex, pintRed, pintGreen, pintBlue, pintAlpha)
        If (pintColorIndex >= 0) And (pintColorIndex < intNumberOfColors) Then
            arrData(pintColorIndex, 0) = pintRed
            arrData(pintColorIndex, 1) = pintGreen
            arrData(pintColorIndex, 2) = pintBlue
            arrData(pintColorIndex, 3) = pintAlpha
        End If
    End Function
    Public Property Get NumberOfColors
        NumberOfColors = intNumberOfColors
    End Property
    Public Property Get MaximumComponentValue
        MaximumComponentValue = intBitsPerComponent
    End Property
    Public Function GetBMPData
        Dim intIndex
        For intIndex = 0 To intNumberOfColors - 1
            GetBMPData = GetBMPData & Chr(arrData(intIndex, 2) * 255 \ (2 ^ intBitsPerComponent - 1)) & Chr(arrData(intIndex, 1) * 255 \ (2 ^ intBitsPerComponent - 1)) & Chr(arrData(intIndex, 0) * 255 \ (2^intBitsPerComponent - 1)) & Chr(arrData(intIndex, 3))
        Next
    End Function
End Class

Class Image
    Private intWidth
    Private intHeight
    Private intBitDepth
    Private arrData()
    Private Sub Class_Initialize()
        intWidth = 0
        intHeight = 0
        intBitDepth = 0
    End Sub
    Public Function SetProperties(pintWidth, pintHeight, pintBitDepth)
        SetProperties = False
        If (pintWidth > 0) And (pintHeight > 0) And ((pintBitDepth = 4) Or (pintBitDepth = 8) Or (pintBitDepth = 24)) Then
            intWidth = pintWidth
            intHeight = pintHeight
            intBitDepth = pintBitDepth
            ReDim arrData(pintWidth * pintHeight - 1)
            Dim i
            For i = 0 To UBound(arrData)
                arrData(i) = 0
            Next
            SetProperties = True
        End If
    End Function
    Public Property Get Width
        Width = intWidth
    End Property
    Public Property Get Height
        Height = intHeight
    End Property
    Public Property Get BitDepth
        BitDepth = intBitDepth
    End Property
    Public Function SetPixel(pintX, pintY, pintValue)
        SetPixel = False
        If (pintX >= 0) And (pintX <= intWidth - 1) And (pintY >= 0) And (pintY <= intHeight - 1) And (pintValue <= 2 ^ intBitDepth - 1) Then
            arrData(pintY * intWidth + pintX) = pintValue
            SetPixel = True
        End If
    End Function
    Public Function GetPixel(pintX, pintY)
        GetPixel = 0
        If (pintX >= 0) And (pintX <= intWidth - 1) And (pintY >= 0) And (pintY <= intHeight - 1) Then
            GetPixel = arrData(pintY * intWidth + pintX)
        End If
    End Function
    Public Function PutImage(pintX, pintY, pImage, pblnHorizontalFlip, pblnVerticalFlip)
        PutImage = False
        If (pintX >= 0) And (pintX + pImage.Width <= intWidth) And (pintY >= 0) And (pintY + pImage.Height <= intHeight) Then
            Dim x, y, tmpVal
            For y = 0 To pImage.Height - 1
                tmpVal = (pintY + y) * intWidth + pintX
                For x = 0 To pImage.Width - 1
                    If pblnHorizontalFlip Then
                        If pblnVerticalFlip Then
                            arrData(tmpVal + x) = pImage.GetPixel(pImage.Width - 1 - x, pImage.Height - 1 - y)
                        Else
                            arrData(tmpVal + x) = pImage.GetPixel(pImage.Width - 1 - x, y)
                        End If
                    Else
                        If pblnVerticalFlip Then
                            arrData(tmpVal + x) = pImage.GetPixel(x, pImage.Height - 1 - y)
                        Else
                            arrData(tmpVal + x) = pImage.GetPixel(x, y)
                        End If
                    End If
                Next
            Next
            PutImage = True
        End If
    End Function
    Public Function ExportToBMP(pstrFileName, pobjPalette)
        Dim intLinePadding, intImageOffset, intBitmapSize, strBMPData, intNumberOfColors
        intLinePadding = (intWidth * intBitDepth)
        If intLinePadding >= 32 Then
            intLinePadding = intLinePadding Mod 32
            If intLinePadding <> 0 Then
                intLinePadding = 32 - intLinePadding
            End If
        Else
            intLinePadding = 32 - intLinePadding
        End If
        If intBitDepth <> 24 Then
            intNumberOfColors = pobjPalette.NumberOfColors
        Else
            intNumberOfColors = 0
        End If
        intImageOffset = 54 + 4 * intNumberOfColors
        intBitmapSize = ((intWidth * intBitDepth) + intLinePadding) * intHeight / 8
        strBMPData = "BM"
        strBMPData = strBMPData & IntToString(intImageOffset + intBitmapSize)
        strBMPData = strBMPData & Chr(0) & Chr(0)
        strBMPData = strBMPData & Chr(0) & Chr(0)
        strBMPData = strBMPData & IntToString(intImageOffset)
        strBMPData = strBMPData & Chr(40) & Chr(0) & Chr(0) & Chr(0)
        strBMPData = strBMPData & IntToString(intWidth)
        strBMPData = strBMPData & IntToString(intHeight)
        strBMPData = strBMPData & Chr(1) & Chr(0)
        strBMPData = strBMPData & Chr(intBitDepth) & Chr(0)
        strBMPData = strBMPData & Chr(0) & Chr(0) & Chr(0) & Chr(0)
        strBMPData = strBMPData & IntToString(intBitmapSize)
        strBMPData = strBMPData & Chr(&h13) & Chr(&h0B) & Chr(0) & Chr(0)
        strBMPData = strBMPData & Chr(&h13) & Chr(&h0B) & Chr(0) & Chr(0)
        strBMPData = strBMPData & IntToString(intNumberOfColors)
        strBMPData = strBMPData & IntToString(intNumberOfColors)
        If intBitDepth <> 24 Then
            strBMPData = strBMPData & pobjPalette.GetBMPData
        End If
        Dim intX, intY, intIndex, objStringBuilder
        Set objStringBuilder = New StringBuilder
        objStringBuilder.Append strBMPData
        Select Case intBitDepth
            Case 4
                Dim intByte, intNumberOfNibbles
                intLinePadding = intLinePadding \ 4
                intNumberOfNibbles = 0
                intByte = 0
                For intY = intHeight - 1 To 0 Step -1
                    For intX = 0 To intWidth - 1
                        intByte = intByte * 16 + arrData(intY * intWidth + intX)
                        intNumberOfNibbles = intNumberOfNibbles + 1
                        If intNumberOfNibbles = 2 Then
                            objStringBuilder.Append Chr(intByte)
                            intByte = 0
                            intNumberOfNibbles = 0
                        End If
                    Next
                    If intLinePadding <> 0 Then
                        For intIndex = 0 To intLinePadding - 1
                            intByte = intByte * 16 + 0
                            intNumberOfNibbles = intNumberOfNibbles + 1
                            If intNumberOfNibbles = 2 Then
                                objStringBuilder.Append Chr(intByte)
                                intNumberOfNibbles = 0
                            End If
                        Next
                        If intNumberOfNibbles = 1 Then
                            objStringBuilder.Append Chr(intByte * 16)
                            intNumberOfNibbles = 0
                        End If
                    End If
                Next
            Case 8
                intLinePadding = intLinePadding \ 8
                For intY = intHeight - 1 To 0 Step -1
                    For intX = 0 To intWidth - 1
                        objStringBuilder.Append Chr(arrData(intY * intWidth + intX))
                    Next
                    If intLinePadding <> 0 Then
                        For intIndex = 0 To intLinePadding - 1
                            objStringBuilder.Append Chr(0)
                        Next
                    End If
                Next
            Case 24
                intLinePadding = intLinePadding \ 8
                Dim intPixel
                For intY = intHeight - 1 To 0 Step -1
                    For intX = 0 To intWidth - 1
                        intPixel = arrData(intY * intWidth + intX)
                        objStringBuilder.Append Chr((intPixel \ 65536) And &HFF)
                        objStringBuilder.Append Chr((intPixel \ 256) And &HFF)
                        objStringBuilder.Append Chr((intPixel) And &HFF)
                    Next
                    If intLinePadding <> 0 Then
                        For intIndex = 0 To intLinePadding - 1
                            objStringBuilder.Append Chr(0)
                        Next
                    End If
                Next
        End Select
        Dim objFileSystemObject
        Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
        Dim objBMPFile
        Set objBMPFile = objFileSystemObject.OpenTextFile(pstrFileName, ForWriting, True)
        objBMPFile.Write objStringBuilder.ToString
        objBMPFile.Close
    End Function
    Private Function IntToString(pintValue)
        Dim intPart1, intPart2, intPart3, intPart4
        intPart1 = (pintValue And &h000000FF)
        intPart2 = (pintValue \ 256) And &h000000FF
        intPart3 = (pintValue \ 65536) And &h000000FF
        intPart4 = (pintValue \ 16777216) And &h000000FF
        IntToString = Chr(intPart1) & Chr(intPart2) & Chr(intPart3) & Chr(intPart4)
    End Function
    Public Function TextDump
        Dim x, y
        TextDump = ""
        For y = 0 To Height - 1
            For x = 0 To Width - 1
                TextDump = TextDump & arrData(y * intWidth + x)
                If x <> Width - 1 Then
                    TextDump = TextDump & vbTab
                End If
            Next
            TextDump = TextDump & vbCrLf
        Next
    End Function
End Class

以上。