【原创 / 源码】BMP图像高速切割公共函数 - Office中国论坛/Access中国论坛

Option Compare Database

Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'调用说明：

'imgSrc：裁剪源图像控件对象

'imgDest：裁剪目标图像控件对象（可以和源对象相同）

'xDest,yDest：裁剪矩形的起点（左下角为0,0），单位为Pixel

'widthDest,heightDest：裁剪矩形的宽和高，单位为Pixel

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Sub BMP_Cut(ByRef imgSrc As Image, ByRef imgDest As Image, _

ByVal xDest As Long, ByVal yDest As Long, widthDest As Long, heightDest As Long)

Dim arrDest() As Byte, arrSrc() As Byte

Dim widthSrc As Long, heightSrc As Long

Dim scanLineDest As Long, scanLineSrc As Long

Dim biBitCount As Long, biClrUsed As Long, biSize As Long, biCompression As Long

arrSrc = imgSrc.PictureData

'获取和判断图像格式

widthSrc = ReadBytes(arrSrc, 4, 4)

heightSrc = ReadBytes(arrSrc, 8, 4)

biBitCount = ReadBytes(arrSrc, 14, 2)

biClrUsed = ReadBytes(arrSrc, 32, 2)

biSize = ReadBytes(arrSrc, 0, 4)

biCompression = ReadBytes(arrSrc, 16, 4)

If biSize <> 40 Then

      MsgBox "不支持非DIB格式，无法完成裁剪。"

      Exit Sub

ElseIf biCompression <> 0 Then

      MsgBox "不支持压缩格式或BMP 5.0格式，无法完成裁剪。"

      Exit Sub

ElseIf xDest + widthDest > widthSrc Or yDest + heightDest > heightSrc Then

      MsgBox "切割范围超出了图形边界，无法完成裁剪。"

End If



'初始化图形数据头

scanLineSrc = biBitCount * widthSrc

If scanLineSrc Mod 32 > 0 Then

      scanLineSrc = Fix(scanLineSrc / 32) * 4 + 4

Else

      scanLineSrc = scanLineSrc / 8

End If

scanLineDest = biBitCount * widthDest

If scanLineDest Mod 32 > 0 Then

      scanLineDest = Fix(scanLineDest / 32) * 4 + 4

Else

      scanLineDest = scanLineDest / 8

End If

ReDim arrDest(scanLineDest * heightDest + biSize + biClrUsed * 4 - 1)

CopyMemory ByVal VarPtr(arrDest(0)), ByVal VarPtr(arrSrc(0)), biSize + biClrUsed * 4

WriteBytes arrDest, 4, widthDest, 4

WriteBytes arrDest, 8, heightDest, 4

WriteBytes arrDest, 20, scanLineDest * heightDest, 4

'裁剪图形数据

Dim nY As Long

For nY = 0 To heightDest - 1

      CopyMemory ByVal VarPtr(arrDest(nY * scanLineDest + biSize + biClrUsed * 4)), _

         ByVal VarPtr(arrSrc((yDest + nY) * scanLineSrc + (xDest) * biBitCount / 8 + biSize + biClrUsed * 4)), scanLineDest

Next nY

imgDest.PictureData = arrDest

End Sub

'以下为数据块存取公共函数

Public Function Byt2Lng(ByRef arrData() As Byte, ByVal p As Long) As Long

CopyMemory VarPtr(Byt2Lng), VarPtr(arrData(p)), 4

End Function

Public Function Byt2Int(ByRef arrData() As Byte, ByVal p As Long) As Integer

CopyMemory VarPtr(Byt2Int), VarPtr(arrData(p)), 2

End Function

Public Function ReadBytes(arrData() As Byte, p As Long, t As Integer) As Long

If t >= 1 And t <= 4 Then CopyMemory VarPtr(ReadBytes), VarPtr(arrData(p)), t

End Function

Public Sub WriteBytes(ByRef arrData() As Byte, p As Long, Value As Long, t As Integer)

If t >= 1 And t <= 4 Then CopyMemory VarPtr(arrData(p)), VarPtr(Value), t

End Sub