【图像】抖动算法实现真彩色图片高细节256色降级处理【旧帖，效果不好，勿用】
这里所说的高细节并不是我们所说的HDR，也不是用浮点数进行纹理存储……而是在尽可能保证图片不变得“难看”的情况下把图片降级为256色（尤其是对于存储GIF图片非常具有利用价值）。对于256色的图片都有一个调色板 Palette（或颜色表 Color Table）。这个颜色表是如何得到的呢？有很多种方法：
1、用随机数，取得256种颜色的RGB，组成调色板。
2、使用固定的调色板
3、用八叉树算法计算调色板。
其中方法1要看人品。。。人品好的话颜色刚好适合这个图像，人品不好的话就呵呵了。
方法2的调色板意在把24位真彩色的所有颜色中，均匀取出256种颜色。虽然色域很广，但是每种颜色的细节都不高。
方法3能取得接近完美的调色板。但是这个算法比较费内存。特别是图像特别大的时候。
方法3的实现方法，请看我的这个帖子：【C】八叉树算法：BMP颜色降级生成调色板的算法
接下来言归正传：抖动算法的实现原理。
假设我只有黑色和白色两种颜色，然后我要实现如下图的效果，应该怎么让画面更真实？
很简单，我们只需要把黑白的像素点排列一下。我想大家用过碳素笔都知道碳素笔这东西只能画出纯色的线，而不能像铅笔一样画出深浅不同的线条。但是仍然有一种艺术叫“线描”，就是用碳素笔画交叉线实现灰度的效果。那么我们也使用类似的方法，通过排列黑白两色的像素实现灰度的效果。因此处理后的图像效果如下：
至于这个黑白两色的像素怎么排列呢？这里就要讲到最基础的抖动算法：黑白两色的抖动算法。
我们可以看到这些像素的排列很有规律。那么这个规律到底是什么规律呢？我们其实是把一张“亮度矩阵”平铺到图像上，然后通过判断图像中的像素的值是否大于亮度矩阵图的像素的值来判断是白色还是黑色。亮度矩阵是什么样的呢？请看下图，是亮度矩阵的放大图。
然后我们把亮度矩阵图平铺到原图上，根据比较原图和亮度矩阵图的对应像素的结果，得到最终的颜色。
有关彩色图像的抖动算法，我自己提出的这个是根据空间四边形向量逼近指定颜色，用抖动矩阵来选取颜色的算法。亲测效果不好用，请大家不要用。
我来讲讲我的算法。这个是我自己想出来的算法，我并没有参考任何的相关资料。
我的想法是这样的：
假设给定任意颜色(R,G,B)，让我从一个调色板里面取得一个合适的颜色来替代这个颜色，从而实现位图从24位真彩色降级为8位索引颜色。那么第一步就是从调色板里面找出最接近的颜色。
我们把颜色信息(R,G,B)当做一个三维空间的坐标，它的取值范围从(0,0,0)到(255,255,255)，然后我们就可以利用三维空间中计算两点距离的公式找出最相近的颜色了。
我们拿Win7自带的企鹅壁纸做测试。首先看原图：
然后我们通过取得它的最相近颜色，先初步把它降级为256色。
以此为基础，接下来我要讲我的算法原理了。
首先，我们要从256个调色板颜色中，找出4个能包住原始颜色的颜色。所谓的“包住原始颜色”指的是把原始颜色(R,G,B)看做一个三维空间的坐标。然后我们也把调色板中所有的颜色的RGB值看成坐标。那么这样的话，256个调色板项，相当于空间中的256个点。我们再从这些颜色中找到4个点组成一个三棱锥，让原始颜色在三棱锥内部。之后我们就可以通过把抖动算法当成线性插值从而在4个颜色中选出最合适的颜色。
那么这4个颜色肯定首选距离原始颜色最接近的颜色。我的算法是，先找出距离原始颜色最近的颜色，然后取得“对面的”最接近的颜色。这个“对面的”我不好解释，不过我可以用另外一种方法解释，就是取得的这个点，和刚才的两个点，能组成一个钝角三角形，然后原始颜色的位置就在这个三角形的钝角上。
这一步下来，我们取得的颜色值就不像上面图那么像了。
然后找出第三个点。第三个点的要求是必须能和前两个点组合的三角形上能找到原始颜色的点到这个三角形的投影，同时也是所有的这些个点中距离原始颜色最近的点。
最后就是第四个点。这个点是最后一步取得的点。这个点和前面三个点组成一个四面体，这个四面体能包住这个原始颜色的点。
当这个四面体建立后，我们最后要做的就是插值。第一个点、第二个点和原始颜色的点组成一个平面，然后第三个点、第四个点和原始颜色的点组成一个平面，分别计算第一个点、第二个点到第二个平面的距离，然后分别计算第三个点、第四个点到第一个平面的距离，这样就能做好颜色1、2的插值和颜色3、4的插值。做好以后再做最终的插值。计算距离即可。
而这里所说的插值，其实是通过亮度矩阵判断点的颜色值，进行抖动。
看起来很不错，不过这个算法有个缺点，第三、第四步很容易因为找到的点颜色差别太离谱而出现严重的失真情况。就像下图这样：
原图是下面这幅图（随便找的）
处理后，可以看到第三步、第四步取得了过于离谱的颜色：
那么我的解决办法，是通过筛选，把距离过远的颜色筛除。经过这个优化以后就是如下的效果了：
这样第三步、第四步取得的奇怪颜色就被筛掉了。效果好多了！
为了便于大家理解，我决定把VB写的这个源码公开给大家看。VERSION 5.00
Begin VB.Form frmMain
Caption = "取得调色板"
ClientHeight = 6465
ClientLeft = 120
ClientTop = 450
ClientWidth = 16440
LinkTopic = "frmMain"
OLEDropMode = 1'Manual
ScaleHeight = 431
ScaleMode = 3'Pixel
ScaleWidth = 1096
StartUpPosition = 3'窗口缺省
Begin VB.PictureBox picDither
Align = 3'Align Left
BorderStyle = 0'None
Height = 6465
Left = 0
ScaleHeight = 431
ScaleMode = 3'Pixel
ScaleWidth = 457
TabIndex = 6
Top = 0
Visible = 0 'False
Width = 6855
Begin VB.HScrollBar HSDither
Height = 255
Left = 1440
Max = 0
TabIndex = 12
TabStop = 0 'False
Top = 3000
Width = 2415
End
Begin VB.PictureBox picColor4
AutoRedraw = -1'True
BackColor = &H00000000&
BorderStyle = 0'None
Height = 495
Left = 1800
ScaleHeight = 33
ScaleMode = 3'Pixel
ScaleWidth = 33
TabIndex = 11
Top = 0
Visible = 0 'False
Width = 495
End
Begin VB.PictureBox picColor3
AutoRedraw = -1'True
BackColor = &H00000000&
BorderStyle = 0'None
Height = 495
Left = 1200
ScaleHeight = 33
ScaleMode = 3'Pixel
ScaleWidth = 33
TabIndex = 10
Top = 0
Visible = 0 'False
Width = 495
End
Begin VB.PictureBox picColor2
AutoRedraw = -1'True
BackColor = &H00000000&
BorderStyle = 0'None
Height = 495
Left = 600
ScaleHeight = 33
ScaleMode = 3'Pixel
ScaleWidth = 33
TabIndex = 9
Top = 0
Visible = 0 'False
Width = 495
End
Begin VB.PictureBox picColor1
AutoRedraw = -1'True
BackColor = &H00000000&
BorderStyle = 0'None
Height = 495
Left = 0
ScaleHeight = 33
ScaleMode = 3'Pixel
ScaleWidth = 33
TabIndex = 8
Top = 0
Visible = 0 'False
Width = 495
End
Begin VB.PictureBox picResult
AutoRedraw = -1'True
BackColor = &H00000000&
BorderStyle = 0'None
Height = 495
Left = 2400
ScaleHeight = 33
ScaleMode = 3'Pixel
ScaleWidth = 33
TabIndex = 7
Top = 0
Visible = 0 'False
Width = 495
End
End
Begin VB.PictureBox picRightPanel
Align = 4'Align Right
BorderStyle = 0'None
Height = 6465
Left = 15345
ScaleHeight = 431
ScaleMode = 3'Pixel
ScaleWidth = 73
TabIndex = 0
Top = 0
Width = 1095
Begin VB.PictureBox picProgress
BackColor = &H8000000C&
Height = 255
Left = 0
ScaleHeight = 13
ScaleMode = 3'Pixel
ScaleWidth = 69
TabIndex = 14
Top = 4320
Width = 1095
Begin VB.CommandButton cmdProgress
Enabled = 0 'False
Height = 195
Left = 0
Style = 1'Graphical
TabIndex = 15
Top = 0
Width = 1035
End
End
Begin VB.CheckBox ChRandomPalette
Caption = "产生随机调色板"
Height = 615
Left = 0
Style = 1'Graphical
TabIndex = 13
Top = 3600
Width = 1095
End
Begin VB.PictureBox picPal
AutoRedraw = -1'True
BackColor = &H00000000&
BorderStyle = 0'None
Height = 1095
Left = 0
ScaleHeight = 73
ScaleMode = 3'Pixel
ScaleWidth = 73
TabIndex = 5
Top = 2400
Width = 1095
End
Begin VB.OptionButton OpDitherPic
Caption = "抖动图"
Enabled = 0 'False
Height = 495
Left = 0
Style = 1'Graphical
TabIndex = 4
Top = 1920
Value = -1'True
Width = 1095
End
Begin VB.OptionButton OpSrcPic
Caption = "原图"
Enabled = 0 'False
Height = 495
Left = 0
Style = 1'Graphical
TabIndex = 3
Top = 1440
Width = 1095
End
Begin VB.CommandButton cmdDither
Caption = "抖动"
Enabled = 0 'False
Height = 615
Left = 0
TabIndex = 1
Top = 0
Width = 1095
End
End
Begin VB.PictureBox picSrcPic
AutoRedraw = -1'True
AutoSize = -1'True
BorderStyle = 0'None
Height = 255
Left = 0
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 2
Top = 0
Visible = 0 'False
Width = 135
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'==============================================================================
'作者：0xAA55
'论坛：http://www.0xaa55.com/
'版权所有 (C) 2013-2014 技术宅的结界
'请保留原作者信息，否则视为侵权。
'------------------------------------------------------------------------------
Option Explicit
Private Const COLORS_MAX As Long = 256
Private Const COLORS_BITS As Long = 8
Private Const DIST_MAX As Long = 200000
Private Type RGBQUAD
B As Byte
G As Byte
R As Byte
X As Byte
End Type
Private Type BITMAPINFO24
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFOPAL
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
Palette(COLORS_MAX - 1) As RGBQUAD
End Type
Private Declare Function CreateOctreePaletteFromHBITMAP Lib "..\Octree.dll" (ByVal hDC&, ByVal hBitmap&, ByVal Width&, ByVal Height&, ByVal MaxColors&, ByVal ColorBits&, P As RGBQUAD) As Long
Private Declare Function GetBitmapPitch Lib "..\Octree.dll" (ByVal BitCount As Integer, ByVal Width As Long) As Long
Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO24, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOPAL, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0 'color table in RGBs
Private Const DIB_PAL_COLORS = 1 'color table in palette indices
Dim BMIF24 As BITMAPINFO24
Dim BMIFPAL As BITMAPINFOPAL
Dim PW&, PH&
Dim LM() As Byte
Dim QuitLoop As Boolean
Dim SrcPixels() As Byte
Dim Values1() As Byte
Dim Values2() As Byte
Dim Values3() As Byte
Dim Values4() As Byte
Dim Vec1R() As Long, Vec1G() As Long, Vec1B() As Long
Dim Vec2R() As Long, Vec2G() As Long, Vec2B() As Long
Dim Vec3R() As Long, Vec3G() As Long, Vec3B() As Long
Dim Vec4R() As Long, Vec4G() As Long, Vec4B() As Long
Private Const MaxDist As Double = 64
Private Const MaxDistSq As Double = MaxDist * MaxDist
Private Const RefreshInterval As Single = 0.1
Dim ProgWidth As Single
Sub DrawProgress(ByVal Prog As Double)
cmdProgress.Left = (Prog - 1) * ProgWidth
picProgress.Refresh
End Sub
Private Sub cmdDither_Click()
Dim DestPixels() As Byte
Dim Pitch1 As Long, Pitch2 As Long
Dim X&, Y&
Dim I&, LStart1&
Dim L&, LStart2&
Dim K&, DistanceSq As Long, NewDistSq As Long
Dim RDiff As Long, GDiff As Long, BDiff As Long
Dim Tm!, NTm!
cmdDither.Enabled = False
picDither.Visible = True
picDither.Visible = True
Form_Resize
Pitch1 = GetBitmapPitch(24, PW)
Pitch2 = GetBitmapPitch(8, PW)
Erase Values1, Values2, Values3, Values4, SrcPixels
Erase Vec1R, Vec1G, Vec1B
Erase Vec2R, Vec2G, Vec2B
Erase Vec3R, Vec3G, Vec3B
Erase Vec4R, Vec4G, Vec4B
ReDim SrcPixels(Pitch1 * PH - 1)
ReDim DestPixels(Pitch2 * PH - 1)
ReDim Values1(UBound(DestPixels))
ReDim Values2(UBound(DestPixels))
ReDim Values3(UBound(DestPixels))
ReDim Values4(UBound(DestPixels))
ReDim Vec1R(UBound(DestPixels)), Vec1G(UBound(DestPixels)), Vec1B(UBound(DestPixels))
ReDim Vec2R(UBound(DestPixels)), Vec2G(UBound(DestPixels)), Vec2B(UBound(DestPixels))
ReDim Vec3R(UBound(DestPixels)), Vec3G(UBound(DestPixels)), Vec3B(UBound(DestPixels))
ReDim Vec4R(UBound(DestPixels)), Vec4G(UBound(DestPixels)), Vec4B(UBound(DestPixels))
GetDIBits picSrcPic.hDC, picSrcPic.Image.Handle, 0, PH, SrcPixels(0), BMIF24, DIB_RGB_COLORS
'==============================================================================
'步骤1：取得最相近的颜色
'------------------------------------------------------------------------------
LStart1 = 0
LStart2 = 0
picColor1.Visible = True
For Y = 0 To PH - 1
I = LStart1
L = LStart2
For X = 0 To PW - 1
DistanceSq = 255& * 255 * 3
For K = 0 To 255
RDiff = CLng(BMIFPAL.Palette(K).R) - SrcPixels(I + 2)
GDiff = CLng(BMIFPAL.Palette(K).G) - SrcPixels(I + 1)
BDiff = CLng(BMIFPAL.Palette(K).B) - SrcPixels(I + 0)
NewDistSq = RDiff * RDiff + GDiff * GDiff + BDiff * BDiff
If NewDistSq < DistanceSq And NewDistSq <= MaxDistSq Then
Vec1R(L) = RDiff
Vec1G(L) = GDiff
Vec1B(L) = BDiff
Values1(L) = K
DestPixels(L) = K
DistanceSq = NewDistSq
End If
Next
I = I + 3
L = L + 1
Next
NTm = Timer
If NTm - Tm >= RefreshInterval Then
Tm = NTm
SetDIBits picColor1.hDC, picColor1.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
picColor1.PaintPicture picSrcPic.Image, 0, 0, PW, PH - Y, 0, 0, PW, PH - Y
DrawProgress Y / (PH - 1)
picColor1.Refresh
DoEvents
If QuitLoop Then Exit For
End If
LStart1 = LStart1 + Pitch1
LStart2 = LStart2 + Pitch2
Next
SetDIBits picColor1.hDC, picColor1.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress 1
picColor1.Refresh
'==============================================================================
'步骤2：取得和上一步相反的颜色
'------------------------------------------------------------------------------
LStart1 = 0
LStart2 = 0
picColor2.Visible = True
For Y = 0 To PH - 1
I = LStart1
L = LStart2
For X = 0 To PW - 1
DistanceSq = 255& * 255 * 3
Values2(L) = Values1(L)
For K = 0 To 255
RDiff = CLng(BMIFPAL.Palette(K).R) - SrcPixels(I + 2)
GDiff = CLng(BMIFPAL.Palette(K).G) - SrcPixels(I + 1)
BDiff = CLng(BMIFPAL.Palette(K).B) - SrcPixels(I + 0)
If RDiff * Vec1R(L) + GDiff * Vec1G(L) + BDiff * Vec1B(L) < 0 Then
NewDistSq = RDiff * RDiff + GDiff * GDiff + BDiff * BDiff
If NewDistSq < DistanceSq And NewDistSq <= MaxDistSq Then
Vec2R(L) = RDiff
Vec2G(L) = GDiff
Vec2B(L) = BDiff
Values2(L) = K
DestPixels(L) = K
DistanceSq = NewDistSq
End If
End If
Next
I = I + 3
L = L + 1
Next
NTm = Timer
If NTm - Tm >= RefreshInterval Then
Tm = NTm
SetDIBits picColor2.hDC, picColor2.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress Y / (PH - 1)
picColor2.Refresh
DoEvents
If QuitLoop Then Exit For
End If
LStart1 = LStart1 + Pitch1
LStart2 = LStart2 + Pitch2
Next
SetDIBits picColor2.hDC, picColor2.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress 1
picColor2.Refresh
'==============================================================================
'步骤3：取得和上两步相反的颜色
'------------------------------------------------------------------------------
LStart1 = 0
LStart2 = 0
picColor3.Visible = True
For Y = 0 To PH - 1
I = LStart1
L = LStart2
For X = 0 To PW - 1
DistanceSq = 255& * 255 * 3
Values3(L) = Values2(L)
For K = 0 To 255
RDiff = CLng(BMIFPAL.Palette(K).R) - SrcPixels(I + 2)
GDiff = CLng(BMIFPAL.Palette(K).G) - SrcPixels(I + 1)
BDiff = CLng(BMIFPAL.Palette(K).B) - SrcPixels(I + 0)
If RDiff * Vec1R(L) + GDiff * Vec1G(L) + BDiff * Vec1B(L) < 0 And _
RDiff * Vec2R(L) + GDiff * Vec2G(L) + BDiff * Vec2B(L) < 0 Then
NewDistSq = RDiff * RDiff + GDiff * GDiff + BDiff * BDiff
If NewDistSq < DistanceSq And NewDistSq <= MaxDistSq Then
Vec3R(L) = RDiff
Vec3G(L) = GDiff
Vec3B(L) = BDiff
Values3(L) = K
DestPixels(L) = K
DistanceSq = NewDistSq
End If
End If
Next
I = I + 3
L = L + 1
Next
NTm = Timer
If NTm - Tm >= RefreshInterval Then
Tm = NTm
SetDIBits picColor3.hDC, picColor3.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress Y / (PH - 1)
picColor3.Refresh
DoEvents
If QuitLoop Then Exit For
End If
LStart1 = LStart1 + Pitch1
LStart2 = LStart2 + Pitch2
Next
SetDIBits picColor3.hDC, picColor3.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress 1
picColor3.Refresh
'==============================================================================
'步骤4：取得和上三步相反的颜色
'------------------------------------------------------------------------------
LStart1 = 0
LStart2 = 0
picColor4.Visible = True
For Y = 0 To PH - 1
I = LStart1
L = LStart2
For X = 0 To PW - 1
DistanceSq = 255& * 255 * 3
Values4(L) = Values3(L)
For K = 0 To 255
RDiff = CLng(BMIFPAL.Palette(K).R) - SrcPixels(I + 2)
GDiff = CLng(BMIFPAL.Palette(K).G) - SrcPixels(I + 1)
BDiff = CLng(BMIFPAL.Palette(K).B) - SrcPixels(I + 0)
If RDiff * Vec1R(L) + GDiff * Vec1G(L) + BDiff * Vec1B(L) < 0 And _
RDiff * Vec2R(L) + GDiff * Vec2G(L) + BDiff * Vec2B(L) < 0 And _
RDiff * Vec3R(L) + GDiff * Vec3G(L) + BDiff * Vec3B(L) < 0 Then
NewDistSq = RDiff * RDiff + GDiff * GDiff + BDiff * BDiff
If NewDistSq < DistanceSq And NewDistSq <= MaxDistSq Then
Vec4R(L) = RDiff
Vec4G(L) = GDiff
Vec4B(L) = BDiff
Values4(L) = K
DestPixels(L) = K
DistanceSq = NewDistSq
End If
End If
Next
I = I + 3
L = L + 1
Next
NTm = Timer
If NTm - Tm >= RefreshInterval Then
Tm = NTm
SetDIBits picColor4.hDC, picColor4.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress Y / (PH - 1)
picColor4.Refresh
DoEvents
If QuitLoop Then Exit For
End If
LStart1 = LStart1 + Pitch1
LStart2 = LStart2 + Pitch2
Next
SetDIBits picColor4.hDC, picColor4.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress 1
picColor4.Refresh
'==============================================================================
'步骤5：将上面四步取得的颜色进行抖动混合
'------------------------------------------------------------------------------
LStart1 = 0
LStart2 = 0
picResult.Visible = True
Dim DitherValue As Long
For Y = 0 To PH - 1
I = LStart1
L = LStart2
For X = 0 To PW - 1
DitherValue = LM((X And &HF) + (Y And &HF) * &H10)
If Values1(L) = Values2(L) And Values2(L) = Values3(L) And Values3(L) = Values4(L) Then '只有一个颜色
DestPixels(L) = Values1(L)
ElseIf Values1(L) <> Values2(L) And Values2(L) = Values3(L) And Values3(L) = Values4(L) Then '抖动颜色1、2
' Src
' /|~"-,_
' / | ~"-,_
' /| ~"-,_
' / | ~"-,_
' / | ~"-,_
'Values1~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~Values2
Dim Vec1To2R As Long, Vec1To2G As Long, Vec1To2B As Long
Dim Vec1To2Dist As Double, ProjLen As Double
Vec1To2R = Vec2R(L) - Vec1R(L)
Vec1To2G = Vec2G(L) - Vec1G(L)
Vec1To2B = Vec2B(L) - Vec1B(L)
Vec1To2Dist = Sqr(CDbl(Vec1To2R) * Vec1To2R + CDbl(Vec1To2G) * Vec1To2G + CDbl(Vec1To2B) * Vec1To2B)
ProjLen = (-Vec1R(L) * Vec1To2R - Vec1G(L) * Vec1To2G - Vec1B(L) * Vec1To2B) / Vec1To2Dist
If ProjLen * 255 / Vec1To2Dist <= DitherValue Then DestPixels(L) = Values1(L) Else DestPixels(L) = Values2(L)
ElseIf Values1(L) <> Values2(L) And Values2(L) <> Values3(L) And Values3(L) = Values4(L) Then '抖动颜色1、2、3
'P2,
'|\ ~"-,_
'| \ ~"-,_
'|P,__ ~"-,_
'| / ~~""--,,__ ~"-,_
'|L ~~""--===,_
'P1~~~~~~~~~~~~~~~~~~~~~~~~~~~P3
Dim Plane123A As Double, Plane123B As Double, Plane123C As Double, Plane123D As Double
Dim Plane123ABCLen As Double
Dim Vec2To3R As Long, Vec2To3G As Long, Vec2To3B As Long
Vec1To2R = Vec2R(L) - Vec1R(L)
Vec1To2G = Vec2G(L) - Vec1G(L)
Vec1To2B = Vec2B(L) - Vec1B(L)
Vec2To3R = Vec3R(L) - Vec2R(L)
Vec2To3G = Vec3G(L) - Vec2G(L)
Vec2To3B = Vec3B(L) - Vec2B(L)
Plane123A = Vec1To2G * Vec2To3B - Vec1To2B * Vec2To3G
Plane123B = Vec1To2B * Vec2To3R - Vec1To2R * Vec2To3B
Plane123C = Vec1To2R * Vec2To3G - Vec1To2G * Vec2To3R
Plane123D = -(Plane123A * BMIFPAL.Palette(Values1(L)).R + Plane123B * BMIFPAL.Palette(Values1(L)).G + Plane123C * BMIFPAL.Palette(Values1(L)).B)
Plane123ABCLen = Sqr(Plane123A * Plane123A + Plane123B * Plane123B + Plane123C * Plane123C)
Plane123A = Plane123A / Plane123ABCLen
Plane123B = Plane123B / Plane123ABCLen
Plane123C = Plane123C / Plane123ABCLen
Plane123D = Plane123D / Plane123ABCLen
Dim PlaneFace23A As Double, PlaneFace23B As Double, PlaneFace23C As Double, PlaneFace23D As Double
Dim PlaneFace23ABCLen As Double
PlaneFace23A = Vec1G(L) * Plane123C - Vec1B(L) * Plane123B
PlaneFace23B = Vec1B(L) * Plane123A - Vec1R(L) * Plane123C
PlaneFace23C = Vec1R(L) * Plane123B - Vec1G(L) * Plane123A
PlaneFace23D = -(PlaneFace23A * SrcPixels(I + 2) + PlaneFace23B * SrcPixels(I + 1) + PlaneFace23C * SrcPixels(I + 0))
PlaneFace23ABCLen = Sqr(PlaneFace23A * PlaneFace23A + PlaneFace23B * PlaneFace23B + PlaneFace23C * PlaneFace23C)
PlaneFace23A = PlaneFace23A / PlaneFace23ABCLen
PlaneFace23B = PlaneFace23B / PlaneFace23ABCLen
PlaneFace23C = PlaneFace23C / PlaneFace23ABCLen
PlaneFace23D = PlaneFace23D / PlaneFace23ABCLen
Dim P2ToPlaneDist As Double, P3ToPlaneDist As Double, PlaneCutPosition As Double
P2ToPlaneDist = Abs(BMIFPAL.Palette(Values2(L)).R * PlaneFace23A + BMIFPAL.Palette(Values2(L)).G * PlaneFace23B + BMIFPAL.Palette(Values2(L)).B * PlaneFace23C + PlaneFace23D)
P3ToPlaneDist = Abs(BMIFPAL.Palette(Values3(L)).R * PlaneFace23A + BMIFPAL.Palette(Values3(L)).G * PlaneFace23B + BMIFPAL.Palette(Values3(L)).B * PlaneFace23C + PlaneFace23D)
PlaneCutPosition = P2ToPlaneDist / (P2ToPlaneDist + P3ToPlaneDist)
If PlaneCutPosition * 255 <= DitherValue Then DestPixels(L) = Values2(L) Else DestPixels(L) = Values3(L)
Dim PointOnPlaneAnd2To3VecR As Double, PointOnPlaneAnd2To3VecG As Double, PointOnPlaneAnd2To3VecB As Double
PointOnPlaneAnd2To3VecR = CDbl(BMIFPAL.Palette(Values2(L)).R) + Vec2To3R * PlaneCutPosition - SrcPixels(I + 2)
PointOnPlaneAnd2To3VecG = CDbl(BMIFPAL.Palette(Values2(L)).G) + Vec2To3G * PlaneCutPosition - SrcPixels(I + 1)
PointOnPlaneAnd2To3VecB = CDbl(BMIFPAL.Palette(Values2(L)).B) + Vec2To3B * PlaneCutPosition - SrcPixels(I + 0)
Dim VecToThatPointR As Double, VecToThatPointG As Double, VecToThatPointB As Double, VecToThatPointLen As Double
VecToThatPointR = PointOnPlaneAnd2To3VecR - Vec1R(L)
VecToThatPointG = PointOnPlaneAnd2To3VecG - Vec1G(L)
VecToThatPointB = PointOnPlaneAnd2To3VecB - Vec1B(L)
VecToThatPointLen = Sqr(VecToThatPointR * VecToThatPointR + VecToThatPointG * VecToThatPointG + VecToThatPointB * VecToThatPointB)
VecToThatPointR = VecToThatPointR / VecToThatPointLen
VecToThatPointG = VecToThatPointG / VecToThatPointLen
VecToThatPointB = VecToThatPointB / VecToThatPointLen
ProjLen = (-Vec1R(L) * VecToThatPointR - Vec1G(L) * VecToThatPointG - Vec1B(L) * VecToThatPointB) / VecToThatPointLen
If ProjLen * 255 <= DitherValue Then DestPixels(L) = Values1(L)
Else '抖动颜色1、2、3、4
Dim Plane12PA As Double, Plane12PB As Double, Plane12PC As Double, Plane12PD As Double, Plane12PABCLen As Double
Dim Plane34PA As Double, Plane34PB As Double, Plane34PC As Double, Plane34PD As Double, Plane34PABCLen As Double
Plane12PA = Vec1G(L) * Vec2B(L) - Vec1B(L) * Vec2G(L)
Plane12PB = Vec1B(L) * Vec2R(L) - Vec1R(L) * Vec2B(L)
Plane12PC = Vec1R(L) * Vec2G(L) - Vec1G(L) * Vec2R(L)
Plane34PA = Vec3G(L) * Vec4B(L) - Vec3B(L) * Vec4G(L)
Plane34PB = Vec3B(L) * Vec4R(L) - Vec3R(L) * Vec4B(L)
Plane34PC = Vec3R(L) * Vec4G(L) - Vec3G(L) * Vec4R(L)
Plane12PD = -(Plane12PA * SrcPixels(I + 2) + Plane12PB * SrcPixels(I + 1) + Plane12PC * SrcPixels(I + 0))
Plane34PD = -(Plane34PA * SrcPixels(I + 2) + Plane34PB * SrcPixels(I + 1) + Plane34PC * SrcPixels(I + 0))
Plane12PABCLen = Sqr(Plane12PA * Plane12PA + Plane12PB * Plane12PB + Plane12PC * Plane12PC)
Plane34PABCLen = Sqr(Plane34PA * Plane34PA + Plane34PB * Plane34PB + Plane34PC * Plane34PC)
Plane12PA = Plane12PA / Plane12PABCLen
Plane12PB = Plane12PB / Plane12PABCLen
Plane12PC = Plane12PC / Plane12PABCLen
Plane12PD = Plane12PD / Plane12PABCLen
Plane34PA = Plane34PA / Plane34PABCLen
Plane34PB = Plane34PB / Plane34PABCLen
Plane34PC = Plane34PC / Plane34PABCLen
Plane34PD = Plane34PD / Plane34PABCLen
Dim Distance1ToP34 As Double, Distance2ToP34 As Double
Dim Distance3ToP12 As Double, Distance4ToP12 As Double
Distance1ToP34 = Abs(Vec1R(L) * Plane34PA + Vec1G(L) * Plane34PB + Vec1B(L) * Plane34PC + Plane34PD)
Distance2ToP34 = Abs(Vec2R(L) * Plane34PA + Vec2G(L) * Plane34PB + Vec2B(L) * Plane34PC + Plane34PD)
Distance3ToP12 = Abs(Vec3R(L) * Plane12PA + Vec3G(L) * Plane12PB + Vec3B(L) * Plane12PC + Plane12PD)
Distance4ToP12 = Abs(Vec4R(L) * Plane12PA + Vec4G(L) * Plane12PB + Vec4B(L) * Plane12PC + Plane12PD)
Dim P12Cut34 As Double, P34Cut12 As Double
P12Cut34 = Distance3ToP12 + (Distance3ToP12 + Distance4ToP12)
P34Cut12 = Distance1ToP34 + (Distance1ToP34 + Distance2ToP34)
Dim Value12 As Byte, Value34 As Byte
If P12Cut34 * 255 <= DitherValue Then Value34 = Values3(L) Else Value34 = Values4(L)
If P34Cut12 * 255 <= DitherValue Then Value12 = Values1(L) Else Value12 = Values2(L)
Vec1To2R = Vec2R(L) - Vec1R(L)
Vec1To2G = Vec2G(L) - Vec1G(L)
Vec1To2B = Vec2B(L) - Vec1B(L)
Dim Vec3To4R As Long, Vec3To4G As Long, Vec3To4B As Long
Vec3To4R = Vec4R(L) - Vec3R(L)
Vec3To4G = Vec4G(L) - Vec3G(L)
Vec3To4B = Vec4B(L) - Vec3B(L)
Dim CutPoint1R As Double, CutPoint1G As Double, CutPoint1B As Double
Dim CutPoint2R As Double, CutPoint2G As Double, CutPoint2B As Double
CutPoint1R = Vec1R(L) + Vec1To2R * P34Cut12
CutPoint1G = Vec1G(L) + Vec1To2G * P34Cut12
CutPoint1B = Vec1B(L) + Vec1To2B * P34Cut12
CutPoint2R = Vec3R(L) + Vec3To4R * P12Cut34
CutPoint2G = Vec3G(L) + Vec3To4G * P12Cut34
CutPoint2B = Vec3B(L) + Vec3To4B * P12Cut34
Dim Dist12 As Double, Dist34 As Double
Dist12 = Sqr(CutPoint1R * CutPoint1R + CutPoint1G * CutPoint1G + CutPoint1B * CutPoint1B)
Dist34 = Sqr(CutPoint2R * CutPoint2R + CutPoint2G * CutPoint2G + CutPoint2B * CutPoint2B)
If Dist12 * 255 / (Dist12 + Dist34) <= DitherValue Then DestPixels(L) = Value12 Else DestPixels(L) = Value34
End If
I = I + 3
L = L + 1
Next
NTm = Timer
If NTm - Tm >= RefreshInterval Then
Tm = NTm
SetDIBits picResult.hDC, picResult.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress Y / (PH - 1)
picResult.Refresh
DoEvents
If QuitLoop Then Exit For
End If
LStart1 = LStart1 + Pitch1
LStart2 = LStart2 + Pitch2
Next
SetDIBits picResult.hDC, picResult.Image.Handle, 0, PH, DestPixels(0), BMIFPAL, DIB_RGB_COLORS
DrawProgress 1
picResult.Refresh
cmdDither.Enabled = False
OpSrcPic.Enabled = True
OpDitherPic.Enabled = True
OpDitherPic.Value = True
End Sub
Private Sub Form_Load()
With BMIF24
.biSize = 40
.biPlanes = 1
.biBitCount = 24
End With
With BMIFPAL
.biSize = 40
.biPlanes = 1
.biBitCount = COLORS_BITS
.biClrUsed = COLORS_MAX
.biClrImportant = COLORS_MAX
End With
LM = LoadResData(101, "LIGHTMATRIX")
Randomize Timer
ProgWidth = picProgress.ScaleWidth
End Sub
Function Lerp(ByVal V1 As Long, ByVal V2 As Long, ByVal Val_0_255 As Long) As Long
Lerp = V1 + (V2 - V1) * Val_0_255 \ 255
End Function
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Local Error GoTo eHandlr
Picture = LoadPicture(Data.Files(1))
PW = ScaleX(Picture.Width, vbHimetric, vbPixels)
PH = ScaleY(Picture.Height, vbHimetric, vbPixels)
picSrcPic.Move 0, 0, PW, PH
picSrcPic.PaintPicture Picture, 0, 0
picColor1.Cls
picColor2.Cls
picColor3.Cls
picColor4.Cls
picResult.Cls
picColor1.Visible = False
picColor2.Visible = False
picColor3.Visible = False
picColor4.Visible = False
picResult.Visible = False
picColor1.Move PW * 0, 0, PW, PH
picColor2.Move PW * 1, 0, PW, PH
picColor3.Move PW * 2, 0, PW, PH
picColor4.Move PW * 3, 0, PW, PH
picResult.Move PW * 4, 0, PW, PH
picDither_Resize
HSDither_Change
BMIF24.biWidth = PW
BMIF24.biHeight = PH
BMIFPAL.biWidth = PW
BMIFPAL.biHeight = PH
DrawProgress 0
If ChRandomPalette.Value Then
Dim I&
For I = 0 To UBound(BMIFPAL.Palette)
BMIFPAL.Palette(I).R = Rnd * 255
BMIFPAL.Palette(I).G = Rnd * 255
BMIFPAL.Palette(I).B = Rnd * 255
Next
Else
If CreateOctreePaletteFromHBITMAP(hDC, Picture.Handle, PW, PH, COLORS_MAX, COLORS_BITS, BMIFPAL.Palette(0)) = 0 Then
MsgBox "生成调色板失败。", vbExclamation
End If
End If
DrawPal
cmdDither.Enabled = True
OpSrcPic.Enabled = False
OpDitherPic.Enabled = False
OpSrcPic.Value = True
Exit Sub
eHandlr:
MsgBox Err.Description, vbExclamation, "出错"
End Sub
Sub DrawPal()
Dim X&, Y&
Dim DrX&, DrY&
Dim I&
For Y = 0 To 15
DrX = 0
For X = 0 To 15
picPal.Line (DrX, DrY)-(DrX + 4, DrY + 4), RGB(BMIFPAL.Palette(I).R, BMIFPAL.Palette(I).G, BMIFPAL.Palette(I).B), BF
I = I + 1
If I >= COLORS_MAX Then Exit Sub
DrX = DrX + 5
Next
DrY = DrY + 5
Next
End Sub
Private Sub Form_Resize()
On Error Resume Next
picDither.Width = picRightPanel.Left
End Sub
Private Sub Form_Unload(Cancel As Integer)
QuitLoop = True
End
End Sub
Private Sub HSDither_Change()
On Error Resume Next
Dim LeftBegin As Long
LeftBegin = -HSDither.Value
picColor1.Left = LeftBegin + PW * 0
picColor2.Left = LeftBegin + PW * 1
picColor3.Left = LeftBegin + PW * 2
picColor4.Left = LeftBegin + PW * 3
picResult.Left = LeftBegin + PW * 4
End Sub
Private Sub HSDither_Scroll()
HSDither_Change
End Sub
Private Sub OpDitherPic_Click()
picSrcPic.Visible = False
picDither.Visible = True
End Sub
Private Sub OpSrcPic_Click()
picSrcPic.Visible = True
picDither.Visible = False
End Sub
Private Sub picDither_Resize()
On Error Resume Next
Dim PP1W As Long, PP1H As Long, HSMax As Long
PP1W = picDither.ScaleWidth
PP1H = picDither.ScaleHeight
HSDither.Move 0, PP1H - 17, PP1W, 17
HSMax = PW * 5 - PP1W
If HSMax > 0 Then
HSDither.Max = HSMax
HSDither.LargeChange = PP1W
HSDither.Visible = True
Else
HSDither.Value = 0
HSDither.Visible = False
End If
End SubBin下载：
Src下载： Bin的用法忘了补充了。
1、打开EXE
2、把图片拖进去
3、点“抖动按钮”，然后留意底部的滚动条！ 異界型丘比 发表于 2014-6-20 18:20
对我来说可能没什么意义 我基本都是保存PNG的
对我来说，这东西可以做成KKND2游戏的新版地图编辑器。 大佬，这个工具生成的256色位图可以把颜色保留的和原图接近吗？ 谢谢啦，效果非常不错嘛 guodanpier2019 发表于 2019-9-15 13:35
谢谢啦，效果非常不错嘛
这个抖动算法的效果并不好，请参阅论坛里的其它帖子 专业
页:
[1]