ab.com コミュニティ

ActiveBasicを通したコミュニケーション
現在時刻 - 2018年10月22日(月) 23:23

All times are UTC+09:00




新しいトピックを投稿する  トピックへ返信する  [ 1 件の記事 ] 
作成者 メッセージ
投稿記事Posted: 2005年6月18日(土) 23:16 
 フルカラーを256色ビットマップにすることができたらゲーム作成の面でいいな、と思い、次のような関数を実装してみたのですが、うまくいきません。
 ちなみに、ABVer.313です。
コード:
'戻り値
' 成功              … 0
' 色数が256色以上         … COLOR_OVER256
' ビットマップファイルではない  … FILE_NOT_BITMAP
' フルカラービットマップではない … FILE_NOT_FULLCOLOR_BITMAP
' ファイルオープン失敗      … INVALID_BITMAPFILE

Const COLOR_OVER256             = &H0010
Const FILE_NOT_BITMAP           = &H0020
Const FILE_NOT_FULLCOLOR_BITMAP = &H0030
Const INVALID_BITMAPFILE        = &H0040

Function Change256(filename As BytePtr) As Long
	'--------------------------元のファイル--------------------------

	Dim hFile As DWord, bfh As BITMAPFILEHEADER, bih As BITMAPINFOHEADER, dwSize As DWord
	Dim lpBuffer As BytePtr

	'ファイルから読み込み
	hFile = CreateFile(filename, GENERIC_READ, 0, ByVal 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
	If hFile = INVALID_HANDLE_VALUE Then
		Change256 = &H0040 : Exit Function
	End If
	ReadFile(hFile, VarPtr(bfh), 14, VarPtr(dwSize), ByVal 0)
	ReadFile(hFile, VarPtr(bih), 40, VarPtr(dwSize), ByVal 0)
	If bfh.bfType = "BM" Then
		CloseHandle(hFile) : Change256 = &H0020 : Exit Function
	End If
	If bih.biBitCount <> 24 Then
		CloseHandle(hFile) : Change256 = &H0030 : Exit Function
	End If

	lpBuffer = calloc(bih.biSizeImage)    'バッファ領域確保
	ReadFile(hFile, lpBuffer, bih.biSizeImage, VarPtr(dwSize), ByVal 0)
	CloseHandle(hFile)

	'--------------------------減色後のファイル--------------------------

	Dim hFileDest As DWord, bfhDest As BITMAPFILEHEADER, biDest As BITMAPINFO
	Dim lpcpyBuffer As BytePtr, BM[1] As Byte

	'BITMAPINFOHEADER構造体の定義
	biDest.bmiHeader.biSize = 40
	biDest.bmiHeader.biWidth = bih.biWidth
	biDest.bmiHeader.biHeight = bih.biHeight
	biDest.bmiHeader.biPlanes = 1
	biDest.bmiHeader.biBitCount = 8
	biDest.bmiHeader.biCompression = BI_RLE8
	If biDest.bmiHeader.biWidth mod 4 <> 0 Then
		biDest.bmiHeader.biSizeImage = (biDest.bmiHeader.biWidth + 4 - biDest.bmiHeader.biWidth mod 4) * biDest.bmiHeader.biHeight
	Else
		biDest.bmiHeader.biSizeImage = biDest.bmiHeader.biWidth * biDest.bmiHeader.biHeight
	End If

	'BITMAPFILEHEADER構造体の定義
	lstrcpy(BM, "BM")
	memcpy( VarPtr(bfh.bfType), BM, 2)
	bfhDest.bfSize = 40 + 14 + 256 * 4 + biDest.bmiHeader.biSizeImage
	bfhDest.bfOffBits = 40 + 14 + 256 * 4

	'カラーパレット決定
	Dim i As Long, j As Long, c As Integer, p As DWord, l As Long, key As Long
	c = -1 : p = 0
	For j = 0 To bih.biHeight - 1
		For i = 0 To bih.biWidth - 1
			key = 0
			Select Case c
				Case -1
					biDest.bmpColors(0).rgbBlue  = lpBuffer[p]
					biDest.bmpColors(0).rgbGreen = lpBuffer[p + 1]
					biDest.bmpColors(0).rgbRed   = lpBuffer[p + 2]
					c = c + 1
				Case 0
					If biDest.bmpColors(0).rgbBlue <> lpBuffer[p] and _
							biDest.bmpColors(0).rgbGreen <> lpBuffer[p + 1] and _
							biDest.bmpColors(0).rgbRed <> lpBuffer[p + 2] Then
						biDest.bmpColors(1).rgbBlue  = lpBuffer[p]
						biDest.bmpColors(1).rgbGreen = lpBuffer[p + 1]
						biDest.bmpColors(1).rgbRed   = lpBuffer[p + 2]
						c = c + 1
					End If
				Case Else
					If c = 255 Then
						free(lpBuffer) : Change256 = &H0010 : Exit Function
					End If
					For l = 0 To c
						If biDest.bmpColors(l).rgbBlue = lpBuffer[p] and _
								biDest.bmpColors(l).rgbGreen = lpBuffer[p + 1] and _
								biDest.bmpColors(l).rgbRed = lpBuffer[p + 2] Then
							key = key + 1
						End If
					Next
					If key = 0 Then
						biDest.bmpColors(c + 1).rgbBlue  = lpBuffer[p]
						biDest.bmpColors(c + 1).rgbGreen = lpBuffer[p + 1]
						biDest.bmpColors(c + 1).rgbRed   = lpBuffer[p + 2]
						c = c + 1
					End If
			End Select
			p = p + 3
		Next
		If bih.biWidth mod 4 = 0 Then
			p = p + (4 - bih.biWidth mod 4)
		End If
	Next

	'カラーパレットを元にバッファ内容決定
	Dim col As Integer
	lpcpyBuffer = calloc(biDest.bmiHeader.biSizeImage)
	p = 0 : l = 0
	For j = 0 To bih.biHeight - 1
		For i = 0 To bih.biWidth - 1
			For col = 0 To c
				If biDest.bmpColors(c).rgbBlue = lpBuffer[p] and _
						biDest.bmpColors(c).rgbGreen = lpBuffer[p + 1] and _
						biDest.bmpColors(c).rgbRed = lpBuffer[p + 2] Then
					lpcpyBuffer[l] = c
					Exit For
				End If
			Next
			p = p + 3
			l = l + 1
		Next
		If bih.biWidth mod 4 = 0 Then
			p = p + (4 - bih.biWidth mod 4)
			l = l + (4 - biDest.bmiHeader.biWidth mod 4)
		End If
	Next

	'ファイルに書き込み
	hFile = CreateFile(filename, GENERIC_WRITE, 0, ByVal 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
	WriteFile(hFile, VarPtr(bfhDest), 14, VarPtr(dwSize), ByVal 0)
	WriteFile(hFile, VarPtr(biDest), 40 + 256 * 4, VarPtr(dwSize), ByVal 0)
	WriteFile(hFile, lpcpyBuffer, bfhDest.bfSize, VarPtr(dwSize), ByVal 0)
	CloseHandle(hFile)

	'--------------------------バッファ領域解放--------------------------

	free(lpcpyBuffer)
	free(lpBuffer)

	Change256 = 0
End Function
 長くてすみません(^^;


通報する
ページトップ
   
期間内表示:  ソート  
新しいトピックを投稿する  トピックへ返信する  [ 1 件の記事 ] 

All times are UTC+09:00


オンラインデータ

このフォーラムを閲覧中のユーザー: なし & ゲスト[2人]


トピック投稿:  可
返信投稿:  可
記事編集: 不可
記事削除: 不可
ファイル添付: 不可

検索:
ページ移動:  
cron
Powered by phpBB® Forum Software © phpBB Limited
Japanese translation principally by KONISHI Yohsuke