关于图片处理的问题

Question

1.我通过设置窗口上的Picture2的宽度和高度,然后调用SavePicture 方法,生成bmp图片 SavePicture Picture2.Image, BmpFile;
我想问一下picture控件设置最大的尺寸(像素)我设置宽度>2180就报益出错误!我生成最大的图片是 2560*1600,那位高手有办法!!!谢谢.
2.我想读取一个bmp文件,并且把bmp文件中的所有颜色减半,怎么处理使用vb,最好有代码,谢谢各位高手!!!

Answer 1

类模块：
Option Explicit
Private Type BITMAPFILEHEADER
    bfType      As Integer
    bfSize      As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits   As Long
End TypePrivate 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 TypePrivate Type Bitmap
    bmType       As Long
    bmWidth      As Long
    bmHeight     As Long
    bmWidthBytes As Long
    bmPlanes     As Integer
    bmBitsPixel  As Integer
    BmBits       As Long
End TypePrivate Const DIB_RGB_COLORS As Long = 0
Private Const OBJ_BITMAP     As Long = 7
Private Const SRCCOPY        As Long = &HCC0020
Private Const COLORONCOLOR   As Long = 3
Private Const CF_BITMAP      As Long = 2Private 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 Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
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 dwRop As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm50" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)Private mBmpInfoHeader  As BITMAPINFOHEADER
Private mhDC     As Long
Private mhDib    As Long
Private mhOldDib As Long
Private mPtr  As Long
Private mWidthBytes As Long
Public Property Get hDC() As Long
    hDC = mhDC
End PropertyPublic Property Get DataSize() As Long
    DataSize = mBmpInfoHeader.biSizeImage
End PropertyPublic Property Get Width() As Long
    Width = mBmpInfoHeader.biWidth
End PropertyPublic Property Get Height() As Long
    Height = mBmpInfoHeader.biHeight
End PropertyPublic Property Get ColorBit() As Long
    ColorBit = mBmpInfoHeader.biBitCount
End PropertyPublic Property Get DataPtr() As Long
    DataPtr = mPtr
End PropertyPublic Property Get WidthBytes() As Long
    WidthBytes = mWidthBytes
End PropertyPublic Function Create(ByVal NewWidth As Long, ByVal NewHeight As Long, Optional ByVal Bits As Long = 32) As Boolean
    Destroy                                 '销毁以前的DIB
    mhDC = CreateCompatibleDC(0)            '创建DIB设备场景
    If (mhDC <> 0) Then                     '创建成功
        With mBmpInfoHeader                     '位图信息头
            .biSize = Len(mBmpInfoHeader)
            .biPlanes = 1
            .biBitCount = Bits
            .biWidth = NewWidth
            .biHeight = NewHeight
            Select Case Bits
                Case 1
                    mWidthBytes = (((.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
                    mWidthBytes = .biWidth * 4
                Case Else
                    Exit Function
            End Select
            .biSizeImage = mWidthBytes * .biHeight
        End With
        mhDib = CreateDIBSection(mhDC, mBmpInfoHeader, DIB_RGB_COLORS, mPtr, 0, 0)   '创建DIB
        If (mhDib <> 0) Then
            mhOldDib = SelectObject(mhDC, mhDib)    '选入设备场景
        Else
            Destroy                         '如果DIB创建失败，需销毁DIB设备场景
        End If
    End If
    Create = (mhDib <> 0)
End FunctionPublic Sub Destroy()
    If mhDC <> 0 Then
        If mhDib <> 0 Then
            SelectObject mhDC, mhOldDib
            DeleteObject mhDib
        End If
        DeleteObject mhDC
        mBmpInfoHeader.biBitCount = 0
        mBmpInfoHeader.biWidth = 0
        mBmpInfoHeader.biHeight = 0
        mBmpInfoHeader.biSizeImage = 0
    End If
    mhDC = 0: mhDib = 0: mhOldDib = 0: mPtr = 0
End SubPublic Function CreateFromStdPicture(ByVal Picture As StdPicture, Optional Bits As Byte = 32, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean
    Dim Bmp As Bitmap
    If GetObject(Picture.handle, Len(Bmp), Bmp) = 0 Then Exit Function
    If (GetObjectType(Picture) = OBJ_BITMAP) Then
        If Bits = 0 Then Bits = Bmp.bmBitsPixel
        Create Bmp.bmWidth, Bmp.bmHeight, Bits
        If mhDib <> 0 Then                      '说明上面的创建函数成功了
            Dim SourceDC As Long, OldDib As Long
            SourceDC = CreateCompatibleDC(mhDC)
            OldDib = SelectObject(SourceDC, Picture.handle)
            BitBlt mhDC, 0, 0, Bmp.bmWidth, Bmp.bmHeight, SourceDC, 0, 0, dwRop
            SelectObject SourceDC, OldDib
            DeleteDC SourceDC
            CreateFromStdPicture = True
        End If
    End If
End FunctionPublic 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, Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean
    If mhDib = 0 Then Exit Function
    If Width = 0 Then Width = mBmpInfoHeader.biWidth
    If Height = 0 Then Height = mBmpInfoHeader.biHeight
    OutPut = BitBlt(OutDC, x, y, Width, Height, mhDC, xSrc, ySrc, dwRop)
End Function

Answer 2

Public Function HalfColor() As Boolean
    If mhDib = 0 Or Me.ColorBit <> 32 Then Exit Function
    Dim i As Long, Maxi As Long
    Dim HalfArray(0 To 255) As Byte
    Dim DataArr(0 To 2) As Byte, pDataArr(0 To 0) As Long
    Dim OldArrPtr As Long, OldpArrPtr As Long
    MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
    Maxi = Me.DataSize \ 4 - 1
    pDataArr(0) = Me.DataPtr
    For i = 0 To 255
        HalfArray(i) = i / 2
    Next
    For i = 0 To Maxi
        DataArr(0) = HalfArray(DataArr(0))
        DataArr(1) = HalfArray(DataArr(1))
        DataArr(2) = HalfArray(DataArr(2))
        pDataArr(0) = pDataArr(0) + 4
    Next
    FreePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
    HalfColor = True
End FunctionPublic Sub MakePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByRef OldArrPtr As Long, ByRef OldpArrPtr As Long)
    Dim Temp As Long, TempPtr As Long
    CopyMemory Temp, ByVal DataArrPtr, 4        '得到DataArrPtr的SAFEARRAY结构的地址
    Temp = Temp + 12                            '这个指针偏移12个字节后就是pvData指针
    CopyMemory TempPtr, ByVal pDataArrPtr, 4    '得到pDataArrPtr的SAFEARRAY结构的地址
    TempPtr = TempPtr + 12                      '这个指针偏移12个字节后就是pvData指针
    CopyMemory OldpArrPtr, ByVal TempPtr, 4     '保存旧地址
    CopyMemory ByVal TempPtr, Temp, 4           '使pDataArrPtr指向DataArrPtr的SAFEARRAY结构的pvData指针
    CopyMemory OldArrPtr, ByVal Temp, 4         '保存旧地址
End SubPublic Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByVal 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    '恢复旧地址
End Sub
窗体测试代码：
Private Declare Function GetTickCount Lib "kernel32" () As LongDim s As New Class1
Dim t As LongPrivate Sub Form_Load()
    s.CreateFromStdPicture Picture1.Picture, 32
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Set s = Nothing
End SubPrivate Sub Command1_Click()
    t = GetTickCount
    s.HalfColor
    s.OutPut Picture1.hDC
    Picture1.Refresh
    Me.Caption = GetTickCount - t
End Sub
速度很快De

Answer 3

都使用CreateDIBSection了，干脆直接用它读BMP算了，速度还会再快些。