概要
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
以上。