vbsの作法 その20

#概要

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

#写真

![image](https://qiita-image-store.s3.amazonaws.com/0/18104/0a00ad5c-2604-d68a-365f-9305a3bde013.png)



#サンプルコード


```
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


```

以上。