說明

之前用的方式是直接透過檔案轉換的方式 速度相對也就比較慢 這次C.K. Tsai提供了用Bitblt去轉換 速度也就快多了 主要的步驟是這樣

1. 產生所需要格式DC物件(如256色 16色 或是單色)
   '1.建立記憶體DC
   hDC = CreateCompatibleDC(0&)
   '2.設定點陣圖資訊以及所需的調色盤
   bi=.....
   '3.由記憶體DC及點陣圖資訊結構，建立Bitmap
   hDIB = CreateDIBSection(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
   '4.記憶體DC選取此256色Bitmap
   OldObj = SelectObject(hDC, hDIB)
2. 用Bitblt將原圖複製到新的DC上
   '1.將圖形由PictureBox轉移至新的Bitmap之記憶體DC，
   'BitBlt()會自動處理色系轉換
   Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
3. 合成檔案
   '1.產生BitmapFileHeader 'BMP檔案 檔頭資訊
   bf=...
   '2.產生BitmapInfoHeader '點陣圖資訊 + ColorTable
   '就是剛剛合成的bi
   '3.取得點陣圖資料陣列
   '從新的Bitmap取出點陣資料，放入Buffer
   Call GetDIBits(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
   '4.寫入檔案
   Put #fp, 1, bf
   Put #fp, , bi
   Put #fp, , buffer

不難了解吧 完整的程式如下 這邊C.K. Tsai已經幫我們包裝了 SaveBMP256,SaveBMP16,SaveBMP2這三個函數
如果要將Picture1上的圖示轉成256色 存到256.bmp只要呼叫
    Call SaveBMP256(Picture1, App.Path & "\256.bmp")
就可以了

程式

'以下程式在模組
'--------------------------------------------------------------
' 原作:C.K. Tsai
'--------------------------------------------------------------
Option Explicit
Type BitmapFileHeader 'BMP檔案 檔頭資訊
    bfType      As String * 2   '="BM"
    bfSize      As Long         '=BMP檔案大小
    bfReserved1 As Integer      '=0, Reserved.
    bfReserved2 As Integer      '=0, Reserved.
    bfOffBits   As Long         'Specifies the offset, in bytes, from the
                                            'BITMAPFILEHEADER structure to the bitmap bits.
End Type

'點陣圖資訊(Win95/NT4與Win98/NT5分別對此結構作了擴充
'定義以增加功能，在此只用最古老原始定義)
Type BitmapInfoHeader
    biSize          As Long     '=40(&H28) 此結構(BitmapInfoHeader)大小
    biWidth         As Long     '點陣圖寬度(單位：像素)
    biHeight        As Long     '點陣圖高度(單位：像素)
    biPlanes        As Integer  '=1
    biBitCount      As Integer  '=1,4,8,24 每個像素以幾個位元儲存
    biCompression   As Long '=0: 未壓縮, =1: 256 Color RLE8, =2: 16 Color RLE4
    biSizeImage     As Long     '=biWidth * biHeight * biBitCount
    biXPelsPerMeter As Long    '=pixels per meter
    biYPelsPerMeter As Long     '=pixels per meter
    biClrUsed       As Long
    biClrImportant  As Long
End Type

Type BitMapInfo256
     bmiHeader As BitmapInfoHeader
     bmiColors(0 To 255) As Long
End Type

Type BitMapInfo16
     bmiHeader As BitmapInfoHeader
     bmiColors(0 To 15) As Long
End Type

Type BitMapInfo2
     bmiHeader As BitmapInfoHeader
     bmiColors(0 To 1) As Long
End Type

Type Bitmap '14 bytes
    bmType As Long         '=0
    bmWidth As Long         '點陣圖寬度(單位：像素)
    bmHeight As Long       '點陣圖高度(單位：像素)
    bmWidthBytes As Long'the number of bytes in each scan line (word aligned)
    bmPlanes As Integer     '=1
    bmBitsPixel As Integer  '每個像素以幾位元儲存
    bmBits As Long          '指標。指向點陣資料陣列
End Type

Const DIB_RGB_COLORS = 0&
Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
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 dwRop As Long) As Long
Declare Function GetDIBits256 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo256, ByVal wUsage As Long) As Long
Declare Function GetDIBits16 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo16, ByVal wUsage As Long) As Long
Declare Function GetDIBits2 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo2, ByVal wUsage As Long) As Long
Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BitMapInfo256, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Declare Function CreateDIBSection16 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BitMapInfo16, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BitMapInfo2, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

Public Function SaveBMP256(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo256, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm) '取得PictureBox中Bitmap之資訊
   
    'BMP圖每條掃描線須為2byte之倍數
    SizeOfArray = (((bm.bmWidth + 3) \ 4) * 4) * bm.bmHeight
    '

   '底下這個區塊定義出整個BMP結構，依序為：
    '1. BitmapFileHeader 'BMP檔案 檔頭資訊
    '2. BitmapInfoHeader '點陣圖資訊 + ColorTable
    '3. 點陣圖資料陣列
   
   With bf 'BMP檔案 檔頭資訊
        .bfType = "BM"                              'BMP檔案識別
        .bfSize = Len(bf) + Len(bi) + SizeOfArray   '=BMP檔案大小
        .bfReserved1 = 0                            '保留欄位
        .bfReserved2 = 0                            '保留欄位
        .bfOffBits = Len(bf) + Len(bi)        '位移值，點陣資料陣列從何開始
    End With
    With bi
        With .bmiHeader '點陣圖資訊
        .biSize = Len(bi.bmiHeader) '=40(&H28)就是此結構(BitmapInfoHeader)大小
        .biWidth = bm.bmWidth           '點陣圖寬度(單位：像素)
        .biHeight = bm.bmHeight         '點陣圖高度(單位：像素)
        .biPlanes = 1
        .biBitCount = 8          '=1,4,8,24. 每個像素以幾個位元儲存
        .biCompression = 0  '=0: 未壓縮, =1: 256 Color RLE8, =2: 16 Color RLE4
        .biSizeImage = SizeOfArray      '點陣資料陣列大小
        End With
        i = 0

        For b = 0 To &HE0 Step &H20 '這個迴圈產生256色ColorTable
            For g = 0 To &HE0 Step &H20
                For r = 0 To &HC0 Step &H40
                    bi.bmiColors(i) = IIf(b = &HE0, &HFF, b) * &H10000 + _
                    IIf(g = &HE0, &HFF, g) * &H100 + IIf(r = &HC0, &HFF, r)
                    i = i + 1
                Next r
            Next g
        Next b
    End With
    ReDim buffer(0 To bi.bmiHeader.biSizeImage - 1) As Byte '點陣圖資料陣列
    '
    hDC = CreateCompatibleDC(0&) '建立記憶體DC

    '由記憶體DC及點陣圖資訊結構，建立256色Bitmap
    hDIB = CreateDIBSection256(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)

    OldObj = SelectObject(hDC, hDIB) '記憶體DC選取此256色Bitmap

    '將圖形由PictureBox轉移至256色Bitmap之記憶體DC，
    'BitBlt()會自動處理色系轉換
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, _
    0&, vbSrcCopy)

    '從256色Bitmap取出點陣資料，放入Buffer
    Call GetDIBits256(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)

    SelectObject hDC, OldObj '功成身退，將物件復原並刪除之
    DeleteDC hDC
    DeleteObject hDIB
    '
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP256 = Err.Number
        Exit Function
    End If
    '將整個BMP結構，用二進位資料模式，依序寫入磁碟
    Put #fp, 1, bf     'BMP檔案 檔頭資訊
    Put #fp, , bi       '點陣圖資訊 + ColorTable
    Put #fp, , buffer  '點陣圖資料陣列
    Close #fp '大工告成
End Function

Public Function SaveBMP16(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo16, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth / 2 + 3) \ 4) * 4) * bm.bmHeight
    '
    With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 4
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
        For i = 0 To 15
            .bmiColors(i) = QBColor(i)
        Next i
    End With
    ReDim buffer(bi.bmiHeader.biSizeImage - 1) As Byte
    '
    hDC = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection16(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
    OldObj = SelectObject(hDC, hDIB)
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
    Call GetDIBits16(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    SelectObject hDC, OldObj
    DeleteDC hDC
    DeleteObject hDIB
    '
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP16 = Err.Number
        Exit Function
    End If
    Put #fp, 1, bf
    Put #fp, , bi
    Put #fp, , buffer
    Close #fp
End Function

Public Function SaveBMP2(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo2, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth / 8 + 3) \ 4) * 4) * bm.bmHeight
    '
    With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 1
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
            .bmiColors(0) = vbWhite
            .bmiColors(1) = vbBlack
    End With
    ReDim buffer(bi.bmiHeader.biSizeImage - 1) As Byte
    '
    hDC = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection2(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
    OldObj = SelectObject(hDC, hDIB)
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
    Call GetDIBits2(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    SelectObject hDC, OldObj
    DeleteDC hDC
    DeleteObject hDIB
    '
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP2 = Err.Number
        Exit Function
    End If
    Put #fp, 1, bf
    Put #fp, , bi
    Put #fp, , buffer
    Close #fp
End Function

Public Function SaveBMP256B(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo256, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm) '取得PictureBox中Bitmap之資訊
   
    'BMP圖每條掃描線須為2byte之倍數
    SizeOfArray = (((bm.bmWidth + 3) \ 4) * 4) * bm.bmHeight
    '

   '底下這個區塊定義出整個BMP結構，依序為：
    '1. BitmapFileHeader 'BMP檔案 檔頭資訊
    '2. BitmapInfoHeader '點陣圖資訊 + ColorTable
    '3. 點陣圖資料陣列
   
   With bf 'BMP檔案 檔頭資訊
        .bfType = "BM"                              'BMP檔案識別
        .bfSize = Len(bf) + Len(bi) + SizeOfArray   '=BMP檔案大小
        .bfReserved1 = 0                            '保留欄位
        .bfReserved2 = 0                            '保留欄位
        .bfOffBits = Len(bf) + Len(bi)        '位移值，點陣資料陣列從何開始
    End With
    With bi
        With .bmiHeader '點陣圖資訊
        .biSize = Len(bi.bmiHeader) '=40(&H28)就是此結構(BitmapInfoHeader)大小
        .biWidth = bm.bmWidth           '點陣圖寬度(單位：像素)
        .biHeight = bm.bmHeight         '點陣圖高度(單位：像素)
        .biPlanes = 1
        .biBitCount = 8          '=1,4,8,24. 每個像素以幾個位元儲存
        .biCompression = 0  '=0: 未壓縮, =1: 256 Color RLE8, =2: 16 Color RLE4
        .biSizeImage = SizeOfArray      '點陣資料陣列大小
        End With

        For i = 0 To 255 '這個迴圈產生256色灰階的ColorTable
            bi.bmiColors(i) = i * &H10000 + _
            i * &H100 + i
        Next i
    End With
    ReDim buffer(0 To bi.bmiHeader.biSizeImage - 1) As Byte '點陣圖資料陣列
    '
    hDC = CreateCompatibleDC(0&) '建立記憶體DC

    '由記憶體DC及點陣圖資訊結構，建立256色Bitmap
    hDIB = CreateDIBSection256(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)

    OldObj = SelectObject(hDC, hDIB) '記憶體DC選取此256色Bitmap

    '將圖形由PictureBox轉移至256色Bitmap之記憶體DC，
    'BitBlt()會自動處理色系轉換
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, _
    0&, vbSrcCopy)

    '從256色Bitmap取出點陣資料，放入Buffer
    Call GetDIBits256(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)

    SelectObject hDC, OldObj '功成身退，將物件復原並刪除之
    DeleteDC hDC
    DeleteObject hDIB
    '
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP256 = Err.Number
        Exit Function
    End If
    '將整個BMP結構，用二進位資料模式，依序寫入磁碟
    Put #fp, 1, bf     'BMP檔案 檔頭資訊
    Put #fp, , bi       '點陣圖資訊 + ColorTable
    Put #fp, , buffer  '點陣圖資料陣列
    Close #fp '大工告成
End Function

---

'以下程式在Form中
'需要兩個Picture : Pic和Picture1,Pic用來存放原始圖檔
'需要4個Command
'Command1 : Caption= "256色"
'Command2 : Caption= "Default"
'Command3 : Caption= "黑白"
'Command4 : Caption= "16 色"
'Command5 : Caption= "256色灰階"
'--------------------------------------------------------------
' 原作:C.K. Tsai
'--------------------------------------------------------------
Option Explicit

Private Sub Command1_click()
    Command1.Enabled = False
    Call SaveBMP256(pic, App.Path & "\256.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\256.bmp")
    Command1.Enabled = True
End Sub

Private Sub Command2_Click()
    SavePicture pic.Picture, App.Path & "\VBDefault.bmp"
    Picture1.Picture = LoadPicture(App.Path & "\VBDefault.bmp")
End Sub


Private Sub Command3_Click()
    Command3.Enabled = False
    Call SaveBMP2(pic, App.Path & "\x2.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\x2.bmp")
    Command3.Enabled = True
End Sub

Private Sub Command4_Click()
    Command4.Enabled = False
    Call SaveBMP16(pic, App.Path & "\x16.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\x16.bmp")
    Command4.Enabled = True
End Sub

Private Sub Command5_Click()
    Command4.Enabled = False
    Call SaveBMP256B(pic, App.Path & "\256B.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\256B.bmp")
    Command5.Enabled = True
End Sub

當然你也可以下在這個範例程式

文件出處

  C.K. Tsai

  Honey加上256灰階部分

整理時間

  2002'2,21.

如果對本站有任何建議,歡迎來信給Honey,我們會盡快給您答覆