www.pudn.com > imagescale---raw.zip > BasDIB.bas
Attribute VB_Name = "BasDIB"
Option Explicit
Public Const CW_USEDEFAULT As Long = &H80000000
'## 位图创建 ###################################
'== Fun ========================================
'CreateDIBSection 创建一个DIBSection。这是一个GDI对象，可象一幅与设备有关位图那样使用。但是，它在内部作为一幅与设备无关位图保存。返回值：Long，执行成功返回DIBSection位图的句柄，零表示失败。会设置GetLastError
'LoadImage 载入一个位图、图标或指针
Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As Any, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'== Const ======================================
Public Const DIB_RGB_COLORS = 0 'BITMAPINFO包含了一个颜色表，其中保存有32位颜色（RGBQUAD）
Public Const DIB_PAL_COLORS = 1 'BITMAPINFO包含了一个16位调色板索引的数组
Public Const IMAGE_BITMAP As Long = 0 '
Public Const IMAGE_ICON As Long = 1 '
Public Const IMAGE_CURSOR As Long = 2 '
Public Const IMAGE_ENHMETAFILE As Long = 3 '
Public Const LR_DEFAULTCOLOR As Long = &H0 '以常规方式载入图象
Public Const LR_MONOCHROME As Long = &H1 '将图象转换成单色
Public Const LR_COLOR As Long = &H2 '
Public Const LR_COPYRETURNORG As Long = &H4 'Creates an exact copy of the image, ignoring the cxDesired and cyDesired parameters.
Public Const LR_COPYDELETEORG As Long = &H8 'Deletes the original image after creating the copy.
Public Const LR_LOADFROMFILE As Long = &H10 '如hInst为零，lpsz就代表要载入适当类型的一个文件的名字，仅适用于Win95
Public Const LR_LOADTRANSPARENT As Long = &H20 '与图象中第一个像素相符的所有像素都由系统替换
Public Const LR_DEFAULTSIZE As Long = &H40 '不对图象进行缩放处理。忽略n1和n2的设置
Public Const LR_VGACOLOR As Long = &H80 '使用真彩色？Uses true VGA colors.
Public Const LR_LOADMAP3DCOLORS As Long = &H1000 '将图象中的深灰、灰、以及浅灰像素都替换成COLOR_3DSHADOW，COLOR_3DFACE以及COLOR_3DLIGHT的当前设置
Public Const LR_CREATEDIBSECTION As Long = &H2000 '如果指定了IMAGE_BITMAP，就返回DIBSection的句柄，而不是位图的句柄
Public Const LR_COPYFROMRESOURCE As Long = &H4000 'Tries to reload an icon or cursor resource from the original resource file rather than simply copying the current image. This is useful for creating a different-sized copy when the resource file contains multiple sizes of the resource. Without this flag, CopyImage stretches the original image to the new size. If this flag is set, CopyImage uses the size in the resource file closest to the desired size.
Public Const LR_SHARED As Long = &H8000 '将图象作为一个共享资源载入。在NT 4.0中装载固有资源时要用到这个设置
'## 位图属性 ###################################
'== Fun ========================================
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long
Public Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function GetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQuad) As Long
Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQuad) As Long
'## Other ######################################
Public Type BITMAPFILEHEADER
bfType(1 To 2) As Byte
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Public Type BitMapInfoHeader
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
Public Const BI_RGB As Long = 0&
Public Const BI_RLE8 As Long = 1&
Public Const BI_RLE4 As Long = 2&
Public Const BI_BitFields As Long = 3&
Public Const BI_JPEG As Long = 4&
Public Const BI_PNG As Long = 5&
Public Type RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public Type BitMapInfo
bmiHeader As BitMapInfoHeader
bmiColors(0 To &HFF) As RGBQuad
End Type
'##################################################
Public Enum ScaleModeConst
SMC_Min = 0
SMC_Nearest = 0 '最邻近插值
SMC_StretchBlt = 1 'StretchBlt
SMC_BiliNear = 2 '双线性内插值
SMC_ThreeOrder = 3 '三次卷积法
SMC_Max = 3
End Enum
Public Function GetWidthBytes(ByVal Width As Long, ByVal ColorBits As Long) As Long
If Width <= 0 Then
GetWidthBytes = 0
Exit Function
End If
Select Case ColorBits
Case 1, 4, 8, 16, 24, 32
Dim TempNum As Long
If ColorBits < 8 Then
TempNum = (Width * ColorBits + 7) \ 8
Else
TempNum = Width * (ColorBits \ 8)
End If
GetWidthBytes = (TempNum + 3) And &H7FFFFFFC
Case Else
GetWidthBytes = 0
End Select
End Function
Public Function DIBLoadMap(ByRef dDIB As ClsDIB, FileName As String, Optional ByVal AutoSize As Boolean = True, Optional ByVal CBit As Long = 24) As Boolean
Dim hMap As Long
Dim hDC As Long
Dim hOldMap As Long
Dim TempPic As IPictureDisp
Dim BM As BitMap
If dDIB Is Nothing Then Set dDIB = New ClsDIB
If dDIB.hDC = 0 Then AutoSize = True
If AutoSize Then
If CBit = 16 Or CBit = 24 Or CBit = 32 Then
Else
Exit Function
End If
End If
'Debug.Print AutoSize
hMap = LoadImage(0, FileName, IMAGE_BITMAP, 0, 0, LR_DEFAULTSIZE Or LR_CREATEDIBSECTION)
If hMap Then
'
Else
On Error Resume Next
Set TempPic = LoadPicture(FileName)
On Error GoTo 0
If TempPic Is Nothing Then
Else
If TempPic.Type = vbPicTypeBitmap Then
hMap = TempPic.handle
Else
Set TempPic = Nothing
End If
End If
End If
If hMap Then
hDC = CreateCompatibleDC(0)
If hDC = 0 Then GoTo FreeMe
GetObjectAPI hMap, Len(BM), BM
If AutoSize Then
If dDIB.Create(BM.bmWidth, BM.bmHeight, CBit, False) Then
Else
GoTo FreeMe
End If
End If
hOldMap = SelectObject(hDC, hMap)
SetStretchBltMode dDIB.hDC, STRETCH_HALFTONE
StretchBlt dDIB.hDC, 0, 0, dDIB.Width, dDIB.Height, hDC, 0, 0, BM.bmWidth, BM.bmHeight, vbSrcCopy
Call SelectObject(hDC, hOldMap)
DIBLoadMap = True
End If
FreeMe:
If hDC Then DeleteDC hDC
If TempPic Is Nothing Then DeleteObject hMap
Set TempPic = Nothing
End Function
Public Function ScaleModeName(ByVal ScaleMode As ScaleModeConst) As String
Dim s As String
Select Case ScaleMode
Case ScaleModeConst.SMC_Nearest
s = "最邻近插值"
Case ScaleModeConst.SMC_StretchBlt
s = "StretchBlt"
Case ScaleModeConst.SMC_BiliNear
s = "双线性内插值"
Case ScaleModeConst.SMC_ThreeOrder
s = "三次卷积法"
End Select
ScaleModeName = s
End Function
Private Function Sinxx(ByVal X As Single) As Single
X = Abs(X)
If X < 1 Then
Sinxx = 1 - 2 * X * X + X * X * X
ElseIf X < 2 Then
Sinxx = 4 - 8 * X + 5 * X * X - X * X * X
Else
Sinxx = 0
End If
End Function
Public Function DIBScale(ByVal ScaleMode As ScaleModeConst, _
ByVal dDIB As ClsDIB, ByVal sDIB As ClsDIB, _
ByVal Width As Long, ByVal Height As Long) As Boolean
If sDIB Is Nothing Then Exit Function
If sDIB.DataPtr = 0 Then Exit Function
If sDIB.ColorBit <> 24 Then Exit Function
If Width < 2 Then Exit Function
If Height < 2 Then Exit Function
If ScaleMode < SMC_Min Or ScaleMode > SMC_Max Then Exit Function
If dDIB Is Nothing Then Set dDIB = New ClsDIB
If dDIB.Create(Width, Height, 24, False) = False Then Exit Function
If Width = sDIB.Width And Height = sDIB.Height Then
CopyMemory ByVal dDIB.DataPtr, ByVal sDIB.DataPtr, sDIB.DataSize
DIBScale = True
Exit Function
End If
Dim pMapData() As Byte
Dim pMapDataInfo As SAFEARRAY1
pMapDataInfo.cDims = 1
pMapDataInfo.fFeatures = 0
pMapDataInfo.cbElements = 1
pMapDataInfo.cLocks = 0
pMapDataInfo.pvData = 0
pMapDataInfo.CE0 = 12
pMapDataInfo.LB0 = 0
pLongAllPtr(0) = VarPtrArray(pMapData)
pLongAll(0) = VarPtr(pMapDataInfo)
Dim sMaxX As Long, sMaxY As Long
Dim dMaxX As Long, dMaxY As Long
sMaxX = sDIB.Width - 1
sMaxY = sDIB.Height - 1
dMaxX = dDIB.Width - 1
dMaxY = dDIB.Height - 1
Dim sPtr As Long, dPtr As Long
Dim sLineBytes As Long, dLineBytes As Long
sPtr = sDIB.DataPtr
dPtr = dDIB.DataPtr
sLineBytes = sDIB.WidthBytes
dLineBytes = dDIB.WidthBytes
Dim sPixelAdd As Long, sLineAdd As Long
Dim dPixelAdd As Long, dLineAdd As Long
sPixelAdd = 3
sLineAdd = sLineBytes - sDIB.Width * sPixelAdd
dPixelAdd = 3
dLineAdd = dLineBytes - dDIB.Width * dPixelAdd
Dim X As Single, Y As Single
Dim nX As Long, nY As Long
Dim u As Single, v As Single
Dim u_ As Single, v_ As Single
Dim LinenX() As Long
Dim Lineu() As Single
Dim I As Long, J As Long
Dim fI As Long, fJ As Long
Dim LinePtr(0 To 3) As Long
Dim CurPtr As Long, CurIdx As Long
Dim OldX As Long, OldY As Long
Dim TempLng As Long
Select Case ScaleMode
Case ScaleModeConst.SMC_Nearest
ReDim LinenX(0 To dMaxX)
For I = 0 To dMaxX
LinenX(I) = I * sMaxX \ dMaxX
Next I
OldY = -2
p3Byte0Ptr(0) = dPtr
For I = 0 To dMaxY
'Y = I * sMaxY / dMaxY
'nY = Int(Y + FloatMinNum)
nY = I * sMaxY \ dMaxY
If nY = OldY Then
CopyMemory ByVal p3Byte0Ptr(0), ByVal p3Byte0Ptr(0) - dLineBytes, dLineBytes
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dLineBytes
Else
OldY = nY
p3Byte1Ptr(0) = sPtr + nY * sLineBytes
OldX = 0
For J = 0 To dMaxX
'nX = J * sMaxX \ dMaxX
nX = LinenX(J)
If nX > OldX Then
p3Byte1Ptr(0) = p3Byte1Ptr(0) + (nX - OldX) * sPixelAdd
OldX = nX
End If
p3Byte0(0) = p3Byte1(0)
p3Byte0(1) = p3Byte1(1)
p3Byte0(2) = p3Byte1(2)
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dPixelAdd
Next J
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dLineAdd
End If
Next I
Case ScaleModeConst.SMC_StretchBlt
SetStretchBltMode dDIB.hDC, STRETCH_HALFTONE
StretchBlt dDIB.hDC, 0, 0, dDIB.Width, dDIB.Height, sDIB.hDC, 0, 0, sDIB.Width, sDIB.Height, vbSrcCopy
Case ScaleModeConst.SMC_BiliNear
Dim MapData(0 To 1, 0 To 1, 0 To 2) As Long
Dim Lineu_() As Single
ReDim LinenX(0 To dMaxX)
ReDim Lineu(0 To dMaxX)
ReDim Lineu_(0 To dMaxX)
For I = 0 To dMaxX
X = I * sMaxX / dMaxX
nX = Int(X)
LinenX(I) = nX
u = X - nX
Lineu(I) = u
Lineu_(I) = 1 - u
Next I
OldX = -1
p3Byte0Ptr(0) = dPtr
For I = 0 To dMaxY
Y = I * sMaxY / dMaxY
nY = Int(Y)
v = Y - nY
v_ = 1 - v
LinePtr(0) = sPtr + nY * sLineBytes
If I = dMaxY Then
LinePtr(1) = LinePtr(0)
Else
LinePtr(1) = LinePtr(0) + sLineBytes
End If
For J = 0 To dMaxX
'X = J * sMaxX / dMaxX
'nX = Int(X)
'u = X - nX
nX = LinenX(J)
u = Lineu(J)
'u_ = 1 - u
u_ = Lineu_(J)
If OldX <> nX Then
CurPtr = nX * sPixelAdd
'For fI = 0 To 1
' pMapDataInfo.pvData = LinePtr(fI) + CurPtr
' 'CurIdx = 0
' 'For fJ = 0 To 1
' ' MapData(fJ, fI, 0) = pMapData(CurIdx)
' ' MapData(fJ, fI, 1) = pMapData(CurIdx + 1)
' ' MapData(fJ, fI, 2) = pMapData(CurIdx + 2)
' ' CurIdx = CurIdx + sPixelAdd
' 'Next fJ
' MapData(0, fI, 0) = pMapData(0)
' MapData(0, fI, 1) = pMapData(1)
' MapData(0, fI, 2) = pMapData(2)
' MapData(1, fI, 0) = pMapData(3)
' MapData(1, fI, 1) = pMapData(4)
' MapData(1, fI, 2) = pMapData(5)
'Next fI
If nX < sMaxX Then
pMapDataInfo.pvData = LinePtr(0) + CurPtr
MapData(0, 0, 0) = pMapData(0)
MapData(0, 0, 1) = pMapData(1)
MapData(0, 0, 2) = pMapData(2)
MapData(1, 0, 0) = pMapData(3)
MapData(1, 0, 1) = pMapData(4)
MapData(1, 0, 2) = pMapData(5)
pMapDataInfo.pvData = LinePtr(1) + CurPtr
MapData(0, 1, 0) = pMapData(0)
MapData(0, 1, 1) = pMapData(1)
MapData(0, 1, 2) = pMapData(2)
MapData(1, 1, 0) = pMapData(3)
MapData(1, 1, 1) = pMapData(4)
MapData(1, 1, 2) = pMapData(5)
Else
pMapDataInfo.pvData = LinePtr(0) + CurPtr
MapData(0, 0, 0) = pMapData(0)
MapData(0, 0, 1) = pMapData(1)
MapData(0, 0, 2) = pMapData(2)
MapData(1, 0, 0) = pMapData(0)
MapData(1, 0, 1) = pMapData(1)
MapData(1, 0, 2) = pMapData(2)
pMapDataInfo.pvData = LinePtr(1) + CurPtr
MapData(0, 1, 0) = pMapData(0)
MapData(0, 1, 1) = pMapData(1)
MapData(0, 1, 2) = pMapData(2)
MapData(1, 1, 0) = pMapData(0)
MapData(1, 1, 1) = pMapData(1)
MapData(1, 1, 2) = pMapData(2)
End If
OldX = nX
End If
'For fI = 0 To 2
' p3Byte0(fI) = (MapData(0, 0, fI) * u_ + MapData(0, 1, fI) * u) * v_ + (MapData(1, 0, fI) * u_ + MapData(1, 1, fI) * u) * v
'Next fI
p3Byte0(0) = (MapData(0, 0, 0) * u_ + MapData(1, 0, 0) * u) * v_ + (MapData(0, 1, 0) * u_ + MapData(1, 1, 0) * u) * v
p3Byte0(1) = (MapData(0, 0, 1) * u_ + MapData(1, 0, 1) * u) * v_ + (MapData(0, 1, 1) * u_ + MapData(1, 1, 1) * u) * v
p3Byte0(2) = (MapData(0, 0, 2) * u_ + MapData(1, 0, 2) * u) * v_ + (MapData(0, 1, 2) * u_ + MapData(1, 1, 2) * u) * v
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dPixelAdd
Next J
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dLineAdd
Next I
Case ScaleModeConst.SMC_ThreeOrder
Dim MatrixA(0 To 3) As Single
Dim MatrixB(0 To 3, 0 To 3, 0 To 2) As Byte
Dim MatrixC(0 To 3) As Single
Dim MatrixT(0 To 3, 0 To 2) As Single
Dim TempSng As Single
'Dim xAdd(0 To 3) As Long
Dim yAdd(0 To 3) As Long
ReDim LinenX(0 To dMaxX)
ReDim Lineu(0 To dMaxX)
For I = 0 To dMaxX
X = I * sMaxX / dMaxX
nX = Int(X)
LinenX(I) = nX
Lineu(I) = X - nX
Next I
Dim ThisLinePixelAdd(0 To 3) As Long
Dim LinePixelAdd() As Long
ReDim LinePixelAdd(-1 To sMaxX + 2)
For I = 0 To sMaxX
LinePixelAdd(I) = I * sPixelAdd
Next I
LinePixelAdd(-1) = 0
LinePixelAdd(sMaxX + 1) = LinePixelAdd(sMaxX)
LinePixelAdd(sMaxX + 2) = LinePixelAdd(sMaxX)
OldX = -1
p3Byte0Ptr(0) = dPtr
For I = 0 To dMaxY
Y = I * sMaxY / dMaxY
nY = Int(Y)
v = Y - nY
'For fI = 0 To 3
' MatrixA(fI) = Sinxx(fI - 1 - v)
'Next fI
TempSng = 1 + v
MatrixA(0) = 4 - 8 * TempSng + 5 * TempSng * TempSng - TempSng * TempSng * TempSng
MatrixA(1) = 1 - 2 * v * v + v * v * v
TempSng = 1 - v
MatrixA(2) = 1 - 2 * TempSng * TempSng + TempSng * TempSng * TempSng
TempSng = 2 - v
MatrixA(3) = 4 - 8 * TempSng + 5 * TempSng * TempSng - TempSng * TempSng * TempSng
yAdd(0) = IIf(nY > 0, -1, 0)
yAdd(1) = 0
If nY < sMaxY - 1 Then
yAdd(2) = 1
yAdd(3) = 2
ElseIf nY < sMaxY Then
yAdd(2) = 1
yAdd(3) = 1
Else
yAdd(2) = 0
yAdd(3) = 0
End If
For fI = 0 To 3
LinePtr(fI) = sPtr + (nY + yAdd(fI)) * sLineBytes
Next fI
For J = 0 To dMaxX
'X = J * sMaxX / dMaxX
'nX = Int(X)
'u = X - nX
nX = LinenX(J)
u = Lineu(J)
'For fI = 0 To 3
' MatrixC(fI) = Sinxx(fI - 1 - u)
'Next fI
TempSng = 1 + u
MatrixC(0) = 4 - 8 * TempSng + 5 * TempSng * TempSng - TempSng * TempSng * TempSng
MatrixC(1) = 1 - 2 * u * u + u * u * u
TempSng = 1 - u
MatrixC(2) = 1 - 2 * TempSng * TempSng + TempSng * TempSng * TempSng
TempSng = 2 - u
MatrixC(3) = 4 - 8 * TempSng + 5 * TempSng * TempSng - TempSng * TempSng * TempSng
If nX <> OldX Then
CurIdx = nX
ThisLinePixelAdd(0) = LinePixelAdd(CurIdx) - LinePixelAdd(CurIdx - 1)
CurIdx = CurIdx + 1
ThisLinePixelAdd(1) = LinePixelAdd(CurIdx) - LinePixelAdd(CurIdx - 1)
CurIdx = CurIdx + 1
ThisLinePixelAdd(2) = LinePixelAdd(CurIdx) - LinePixelAdd(CurIdx - 1)
CurPtr = LinePixelAdd(nX - 1)
For fI = 0 To 3
pMapDataInfo.pvData = LinePtr(fI) + CurPtr
For fJ = 0 To 3
MatrixB(fJ, fI, 0) = pMapData(0)
MatrixB(fJ, fI, 1) = pMapData(1)
MatrixB(fJ, fI, 2) = pMapData(2)
pMapDataInfo.pvData = pMapDataInfo.pvData + ThisLinePixelAdd(fJ)
Next fJ
Next fI
For fI = 0 To 2
MatrixT(0, fI) = MatrixA(0) * MatrixB(0, 0, fI) + MatrixA(1) * MatrixB(0, 1, fI) + MatrixA(2) * MatrixB(0, 2, fI) + MatrixA(3) * MatrixB(0, 3, fI)
MatrixT(1, fI) = MatrixA(0) * MatrixB(1, 0, fI) + MatrixA(1) * MatrixB(1, 1, fI) + MatrixA(2) * MatrixB(1, 2, fI) + MatrixA(3) * MatrixB(1, 3, fI)
MatrixT(2, fI) = MatrixA(0) * MatrixB(2, 0, fI) + MatrixA(1) * MatrixB(2, 1, fI) + MatrixA(2) * MatrixB(2, 2, fI) + MatrixA(3) * MatrixB(2, 3, fI)
MatrixT(3, fI) = MatrixA(0) * MatrixB(3, 0, fI) + MatrixA(1) * MatrixB(3, 1, fI) + MatrixA(2) * MatrixB(3, 2, fI) + MatrixA(3) * MatrixB(3, 3, fI)
Next fI
OldX = nX
End If
For fI = 0 To 2
TempLng = MatrixT(0, fI) * MatrixC(0) + MatrixT(1, fI) * MatrixC(1) + MatrixT(2, fI) * MatrixC(2) + MatrixT(3, fI) * MatrixC(3)
If TempLng >= 0 And TempLng <= &HFF Then
p3Byte0(fI) = TempLng
ElseIf TempLng < 0 Then
p3Byte0(fI) = 0
Else
p3Byte0(fI) = &HFF
End If
Next fI
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dPixelAdd
Next J
p3Byte0Ptr(0) = p3Byte0Ptr(0) + dLineAdd
Next I
End Select
pLongAllPtr(0) = VarPtrArray(pMapData)
pLongAll(0) = 0
DIBScale = True
End Function