VB編程-真彩色轉為灰度圖像源碼要點

《VB編程-真彩色轉為灰度圖像源碼要點》由會員分享，可在線閱讀，更多相關《VB編程-真彩色轉為灰度圖像源碼要點（38頁珍藏版）》請在裝配圖網(wǎng)上搜索。

1、VB編程真彩色轉為灰度圖像源碼 ,以下代碼請貼在一個新建的 Cimage類中 Option Explicit Private TypeBITMAPFILEHEADER bfType As Integer bfSize As Long bfReservedl As Integer bfReserved2 As Integer bfOff Bits As Long End Type Private TypeBITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integ

2、er biBitCount As Integer biCompression As Long biSizeimage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biCIrUsed As Long biCIrlmportant As Long End Type Private Typebitmap bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As

3、Integer BmBits As Long End Type Private TypeRGBQUAD Blue As Byte Green As Byte Red As Byte Reserved As Byte End Type Private TypeBITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type 帶掩碼的 正常 真彩色 Private Const BI_bitfields = 3& Private Const BI_RGB = 0 Private Const

4、 DIB_RGB_COLORS = 0 Private ConstOBJ BITMAP = 7 Private ConstSRCCOPY= &HCC0020 Private ConstlMAGE_BITMAP = 0 Private ConstLR_LOADFROMFILE = &H10 Private ConstLR_CREATEDIBSECTION = &H2000 而不是位圖的句柄 Private Const STRETCH_ANDSCANS = 1 個模式通常應用于采用了白色背景的單色位圖 Private ConstSTRETCH_ORSCANS = 2 Priva

5、te Const STRETCH_DELETESCANS = 3 用于采用了白色背景的單色位圖 Private Const STRETCH_HALFTONE =4 模式要明顯慢于其他模式 位圖對象 ‘直接拷貝 Loadimage函數(shù)的載入類型，位圖 ’從文件載入 如果指定了 IMAGE_BITMAP，就返回D舊Section的句柄, 默認設置。剔除的線段與剩下的線段進行 AND運算。這 剔除的線段被簡單的清除。這個模式通常用于彩色位圖 剔除的線段與剩下的線段進行 OR運算。這個模式通常應 舊標位圖上的像素塊被設為源位圖上大致近似的塊。這個 用于圖像方面的相關 API

6、函數(shù)聲明 \******************************************** Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long Private Declare FunctionCreateCompatibleDC Lib "gdi32

7、" (ByVal hdc As Long) As Long Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, lpRGBQuad As Any) As Long Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQU

8、AD) As Long 用于系統(tǒng)輸出的相關 API 函數(shù)聲明 \******************************************** Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRo

9、p As Long) As Long Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Lo

10、ng) As Long Private Declare FunctionGetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long Private Declare FunctionSetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long 用于內(nèi)存處理的相關 API 函數(shù)聲明 \******************************************** Private Const GMEMFIXED =

11、&H0 Private Const GMEMZEROINIT = &H40 Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT) Private Declare FunctionVarPtrArray Lib "msvbvm50" Alias "V arPtr" (Ptr() As Any) As Long Private Declare FunctionGlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Dec

12、lare FunctionGlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long) Private Declare SubZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal numBytes As Long)

13、公共常用的 API 函數(shù)函數(shù)聲明 \******************************************** Private Declare FunctionDeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare FunctionSelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long 保存了內(nèi)存 DC 當前 DibSection 的句柄 原始 DibSection 的句柄 當前 DibSecti

14、on 的內(nèi)存地址 當前圖像的掃描行字節(jié)數(shù) Private Declare FunctionDeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private mHdc As Long Private mhDib As Long Private mhOldDib As Long Private mPtr As Long Private mWidthBytes As Long Private mBmpInfo As BITMAPINFOHEADER 當前圖像的文件信息 Private Sub Class_Ter

15、minate() Destroy End Sub Public Property Get Width() As Long Width = mBmpInfo.biWidth End Property Public Property Get Height() As Long Height = mBmpInfo.biHeight End Property Public Property Get hdc() As Long hdc = mHdc End Property Public Property Get DataPtr() As Long DataPtr = mPtr

16、 End Property Public Property Get WidthBytes() As Long WidthBytes = mWidthBytes End Property ***************************************************************************************** ** 函 數(shù) 名 ： CreateDib 輸 入 ： Width DIB 的寬度 Height - DIB 的高度 Bits - 位圖的位數(shù)，默認為 32 ** 輸 出 ： 返回是否創(chuàng)建成功

17、** 功能描述 ： 創(chuàng)建新的 DIB \**************************************************************************************** Private Function CreateDib(ByVal Width As Long, ByVal Height As Long, Optional ByVal Bits As Integer = 32) As Boolean Dim i As Long Destroy 銷毀以前的 DIB mHdc = CreateCompatibleDC(0) 創(chuàng)建 D

18、IB 設備場景 If mHdc <> 0 Then With mBmpInfo 位圖信息頭 .biSize = Len(mBmpInfo) .biPlanes = 1 .biBitCount = Bits .biWidth = Width .biHeight = Height .biCompression = BI_RGB Select Case Bits 保證每個掃描行必須是 4 的倍數(shù) Case 1 mWidthBytes =

19、 (((.biWidth + 7) \ 8 + 3) And &HFFFFFFFC) Case 4 mWidthBytes = (((.biWidth + 1) \ 2 + 3) And &HFFFFFFFC) Case 8 mWidthBytes = ((.biWidth + 3) And &HFFFFFFFC) Case 16 mWidthBytes = ((.biWidth * 2 + 3) And &HFFFFFFFC) Case 24 mWidthBytes = ((.biWidth * 3 + 3) And &HFFFFFFFC) Case 32 mWi

20、dthBytes = .biWidth * 4 Case Else Exit Function End Select .biSizeImage = mWidthBytes * .biHeight End With mhDib = CreateDIBSection(mHdc, mBmpInfo, DIB_RGB_COLORS, mPtr, 0, 0) 創(chuàng)建 DIB , mPtr就是指向 這個創(chuàng)建的 DIBSECTION 的內(nèi)存地址 If mhDib <> 0 Then mhOldDib = SelectObject(mHdc, mhDib) If Bits = 8 Then

21、 是灰度圖像，建立起調(diào)色板 ReDim ColorTable(0 To 255) As RGBQUAD For i = 0 To 255 ColorTable(i).Red = i ColorTable(i).Green = i ColorTable(i).Blue = i Next SetDIBColorTable mHdc, 0, 256, ColorTable(0) End If CreateDib = True 選入設備場景 如果是 8位，我們認為它 設置調(diào)色板數(shù)據(jù)

22、 End If End If End Function Public Function LoadPictureFormFile(Filename As String) As Boolean 件或非圖片文件時出錯 On Error Resume Next 防止LoadPicture加載不支持的圖片文 Dim StdPic As StdPicture Dim Width As Long, Height As Long If Dir(Filename) <> "" Then Set StdPic = LoadPicture(

23、Filename) If Not StdPic Is Nothing Then Width = ConvertHimetrix2Pixels(StdPic.Width, True) StdPicture 寬度中的單位是 Himetrics 創(chuàng)建一個空白的 Dib Height = ConvertHimetrix2Pixels(StdPic.Height, False) If CreateDib(Width, Height, 32) = True Then StdPic.Render mHdc + 0, 0, 0, Width + 0, Height + 0, 0, StdPic.

24、Height, StdPic.Width, -StdPic.Height, ByVal 0 類似于 BMP 的逆序存儲，所以用 -StdPic.Height End If Set StdPic = Nothing End If End If End Function Public Function ChangeToGreyMode() As Boolean Dim i As Long, j As Long Dim DataArr(0 To 2) As Byte, pDataArr(0 To 0) As Long Dim OldArrPtr As Long, Oldp

25、ArrPtr As Long Dim DataArrC(0 To 2) As Byte, pDataArrC(0 To 0) As Long Dim OldArrPtrC As Long, OldpArrPtrC As Long Dim LineAddBytes Dim PixelAddBytes Const Blue As Long As Long, mPtrC As Long = 28 As Long Const Green As Long = 150 用 long 可以方便的避免 VB 的溢出錯誤 Const Red As Long = 77 If mHdc

26、 <> 0 And mBmpInfo.biBitCount = 32 Then MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr 綁定模擬指針 MakePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC mPtrC = GlobalAlloc(GPTR, mBmpInfo.biSizeImage) CopyMemory ByVal mPtrC, ByVal mPtr, mBmp

27、Info.biSizeImage 復制真彩色圖像的數(shù)據(jù)，其實就是 一片連續(xù)的內(nèi)存而已 If CreateDib(Width, Height, 8) = True Then 新建一個 8 位位圖 pDataArr(0) = mPtr pDataArrC(0) = mPtrC LineAddBytes = mWidthBytes - mBmpInfo.biWidth 保證每個掃描行的寬度 For i = 1 To mBmpInfo.biHeight For j = 1 To mBmpInfo.biWidth DataArr(0) = (DataArrC(0) * Blue + Da

28、taArrC(1) * Green + DataArrC(2) * Red) \ 255 灰度算 pDataArrC(0) = pDataArrC(0) + 4 pDataArr(0) = pDataArr(0) + 1 Next pDataArr(0) = pDataArr(0) + LineAddBytes 32 位的位圖不需要這個 Next End If GlobalFree mPtrC 釋放分配的內(nèi)存 FreePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr FreePoin

29、t VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC 取消模擬指針 End If ChangeToGreyMode = True End Function Public Function OutPut(ByVal OutDC As Long, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, Optional ByVal Width As Long, Optional ByVal Height As Long, Option

30、al ByVal Srcx As Long = 0, Optional ByVal Srcy As Long = 0, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean If Width = 0 Then Width = mBmpInfo.biWidth If Height = 0 Then Height = mBmpInfo.biHeight OutPut = BitBlt(OutDC, x, y, Width, Height, mHdc, Srcx, Srcy, dwRop) End Function

31、 Public Sub Destroy() If mHdc <> 0 Then If mhDib <> 0 Then SelectObject mHdc, mhOldDib DeleteObject mhDib End If DeleteObject mHdc mBmpInfo.biBitCount = 0 mBmpInfo.biWidth = 0 mBmpInfo.biHeight = 0 mBmpInfo.biSizeimage = 0 End If mHdc = 0: mPtr = 0: m Width Bytes = 0 mhDib = 0: mhOldDi

32、b = 0: End Sub 將 Himetrics 轉變?yōu)?Pixels Private Function ConvertHimetrix2Pixels(HiMetrix As Long, Horizontally As Boolean) As Long If Horizontally Then ConvertHimetrix2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelX Else ConvertHimetrix2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerP

33、ixelY End If End Function \***************************************************************************************** ** 過 程 名 ： MakePoint ** 輸 入 ： ** 功能描述 ： 綁定模擬數(shù)組 I ***********************************************************+ Public Sub MakePoint(ByVal DataArrPtr As Long, OldpArrPtr As Lon

34、g) Dim Temp As Long, TempPtr As Long CopyMemory Temp, ByVai DataArrPtr, 4 Temp = Temp + 12 CopyMemory TempPtr, ByVai pDataArrPtr, 4 TempPtr = TempPtr + 12 CopyMemory OldpArrPtr, By Vai TempPtr, 4 CopyMemory By Vai TempPtr, Temp, 4 指針 CopyMemory OldArrPtr, ByVai Temp, 4 ，*******************

35、********* By Vai pDataArrPtr As Long, By Ref OldArrPtr As Long, By Ref 彳導至ij DataArrPtr的SAFEARRAY結構的地址 這個指針偏移12個字節(jié)后就是pvData指針 彳導至ij pDataArrPtr的SAFEARRAY結構的地址 這個指針偏移12個字節(jié)后就是pvData指針 彳呆存舊地址 使 pDataArrPtr 指向 DataArrPtr 的 SAFEARRAY 結構的 pvData ，保存舊地址 End Sub ***********************************

36、****************************************************** ** 過 程 名 ： FreePoint ** 輸 入 ： ** 功能描述 ： 取消綁定模擬數(shù)組 **************************************************************************************** Public Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByV

37、al OldpArrPtr As Long) Dim TempPtr As Long CopyMemory TempPtr, ByVal DataArrPtr, 4 得到 DataArrPtr 的 SAFEARRAY 結構的地址 CopyMemory ByVal (TempPtr + 12), OldArrPtr, 4 恢復舊地址 CopyMemory TempPtr, ByVal pDataArrPtr, 4 得到 pDataArrPtr 的 SAFEARRAY 結構的地址 CopyMemory ByVal (TempPtr + 12), OldpArrPtr, 4 恢復舊地址

38、 End Sub \***************************************************************************************** ** 過 程 名 ： ChkFileWrite ** 輸 入 ： Filename - 文件路徑，文件不存在，返回錯誤 ** 功能描述 ： 判斷是否可以寫入改文件 **************************************************************************************** Private Function ChkFil

39、eWrite(Filename As String) As Boolean Dim FileNum As Long FileNum = FreeFile On Error Resume Next Open Filename For Output As #FileNum If Err.Number Then Else Close #FileNum ChkFileWrite = True End If End Function 以下位測試代碼: Private Sub Form_Load() Me.AutoRedraw = True Dim Img As New Cim

40、age Img.LoadPictureFormFile "c:\2.bmp" Img.ChangeToGreyMode Img.OutPut Me.hdc Me.Refresh Img.SavePictureToFile "c:\3.bmp" 看看保存后的圖像是不是 8 位的 Img.Destroy 記得一定要銷毀哦 End Sub Public Function SavePictureToFile(Filename As String) As Boolean Dim i As Long, j As Long Dim FileNumber As Long, Col

41、orTable() As RGBQUAD Dim BmpInfoHeader As BITMAPFILEHEADER 目標文件可寫且有數(shù)據(jù)可寫 If ChkFileWrite(Filename) = True And mHdc <> 0 Then BMP 文件的標識 BmpInfoHeader.bfType = &H4D42 If mBmpInfo.biBitCount = 8 Then 只有 biBitCount 等于 1、 4、 8 時才有調(diào)色板 調(diào)色板的大小 BmpInfoHeader.bfOffBits = 54 + 4 * 256 ReDim

42、 ColorTable(0 To 255) As RGBQUAD GetDIBColorTable mHdc, 0, 256, ColorTable(0) ElseIf mBmpInfo.biBitCount = 32 Then BmpInfoHeader.bfOffBits = 54 End If BmpInfoHeader.bfSize = BmpInfoHeader.bfOffBits + mBmpInfo.biSizeImage 文件大小 FileNumber = FreeFile BMP 文件頭 位圖信息頭 調(diào)色板 Open Filename For Binar

43、y As #FileNumber Put #FileNumber, , BmpInfoHeader Put #FileNumber, , mBmpInfo If mBmpInfo.biBitCount = 8 Then Put #FileNumber, , ColorTable ReDim DibBytes(1 To mBmpInfo.biSizeImage) As Byte CopyMemory DibBytes(1), ByVal mPtr, mBmpInfo.biSizeImage Put #FileNumber, , DibBytes 位圖數(shù)據(jù) Close #FileNumber SavePictureToFile = True End If End Function