ちなみに、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