Public Function BrightnessBits(ByVal Pic As PictureBox, ByVal Value As Long) As Boolean
Dim MyhDC As Long
Dim MyBMIH As BitMapInfoHeader
Dim MyhDIB As Long
Dim MyPtr As Long
Dim hOldMap As Long
Dim MapData() As Byte
Dim TempValue As Long
Dim BrightTable(255) As Byte
Dim I As Long
Dim MaxI As Long
With MyBMIH
.biSize = Len(MyBMIH)
.biWidth = Pic.ScaleWidth
.biHeight = Pic.ScaleHeight
.biPlanes = 1
.biBitCount = 24
.biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
End With
MyhDC = CreateCompatibleDC(0)
MyhDIB = CreateDIBSection(MyhDC, MyBMIH, 0, MyPtr, 0, 0)
If MyhDIB Then
hOldMap = SelectObject(MyhDC, MyhDIB)
Else
DeleteObject MyhDC
Exit Function
End If
BitBlt MyhDC, 0, 0, MyBMIH.biWidth, MyBMIH.biHeight, Pic.hDC, 0, 0, vbSrcCopy
MaxI = MyBMIH.biSizeImage - 1
ReDim MapData(0 To MaxI)
Debug.Print "GetBitmapBits:", GetBitmapBits(MyhDIB, MyBMIH.biSizeImage, MapData(0))
For I = 0 To 255
TempValue = I * Value / 100
If TempValue > 255 Then
BrightTable(I) = 255
Else
BrightTable(I) = TempValue
End If
Next I
For I = 0 To MaxI
MapData(I) = BrightTable(MapData(I))
Next I
call SetBitmapBits(MyhDIB, MyBMIH.biSizeImage, MapData(0))
BitBlt Pic.hDC, 0, 0, MyBMIH.biWidth, MyBMIH.biHeight, MyhDC, 0, 0, vbSrcCopy
If hOldMap Then DeleteObject SelectObject(MyhDC, hOldMap)
DeleteObject MyhDC
BrightnessBits = True
End FunctionPrivate Sub CmdStart_Click()
PicView2.Width = PicView1.Width
PicView2.Height = PicView1.Height
Me.MousePointer = vbHourglass
DoEvents
BitBlt PicView2.hDC, 0, 0, PicView1.ScaleWidth, PicView1.ScaleHeight, PicView1.hDC, 0, 0, vbSrcCopy
BrightnessBits PicView2, 200
PicView2.Refresh
ScrollSize
Me.MousePointer = vbDefault
End Sub
Private Sub CmdSave_Click()
On Error GoTo ErrSave
CDlgSave.ShowSave
SavePicture PicView2.Picture, CDlgSave.FileName
On Error GoTo 0
Exit Sub
ErrSave:
If Err.Number = cdlCancel Then
Else
MsgBox Err.Description, vbCritical, Err.Number
End If
End SubPicView1,PicView2均为PictureBox ,AutoRedrew为True
保存时出现无效属性值
Dim MyhDC As Long
Dim MyBMIH As BitMapInfoHeader
Dim MyhDIB As Long
Dim MyPtr As Long
Dim hOldMap As Long
Dim MapData() As Byte
Dim TempValue As Long
Dim BrightTable(255) As Byte
Dim I As Long
Dim MaxI As Long
With MyBMIH
.biSize = Len(MyBMIH)
.biWidth = Pic.ScaleWidth
.biHeight = Pic.ScaleHeight
.biPlanes = 1
.biBitCount = 24
.biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
End With
MyhDC = CreateCompatibleDC(0)
MyhDIB = CreateDIBSection(MyhDC, MyBMIH, 0, MyPtr, 0, 0)
If MyhDIB Then
hOldMap = SelectObject(MyhDC, MyhDIB)
Else
DeleteObject MyhDC
Exit Function
End If
BitBlt MyhDC, 0, 0, MyBMIH.biWidth, MyBMIH.biHeight, Pic.hDC, 0, 0, vbSrcCopy
MaxI = MyBMIH.biSizeImage - 1
ReDim MapData(0 To MaxI)
Debug.Print "GetBitmapBits:", GetBitmapBits(MyhDIB, MyBMIH.biSizeImage, MapData(0))
For I = 0 To 255
TempValue = I * Value / 100
If TempValue > 255 Then
BrightTable(I) = 255
Else
BrightTable(I) = TempValue
End If
Next I
For I = 0 To MaxI
MapData(I) = BrightTable(MapData(I))
Next I
call SetBitmapBits(MyhDIB, MyBMIH.biSizeImage, MapData(0))
BitBlt Pic.hDC, 0, 0, MyBMIH.biWidth, MyBMIH.biHeight, MyhDC, 0, 0, vbSrcCopy
If hOldMap Then DeleteObject SelectObject(MyhDC, hOldMap)
DeleteObject MyhDC
BrightnessBits = True
End FunctionPrivate Sub CmdStart_Click()
PicView2.Width = PicView1.Width
PicView2.Height = PicView1.Height
Me.MousePointer = vbHourglass
DoEvents
BitBlt PicView2.hDC, 0, 0, PicView1.ScaleWidth, PicView1.ScaleHeight, PicView1.hDC, 0, 0, vbSrcCopy
BrightnessBits PicView2, 200
PicView2.Refresh
ScrollSize
Me.MousePointer = vbDefault
End Sub
Private Sub CmdSave_Click()
On Error GoTo ErrSave
CDlgSave.ShowSave
SavePicture PicView2.Picture, CDlgSave.FileName
On Error GoTo 0
Exit Sub
ErrSave:
If Err.Number = cdlCancel Then
Else
MsgBox Err.Description, vbCritical, Err.Number
End If
End SubPicView1,PicView2均为PictureBox ,AutoRedrew为True
保存时出现无效属性值
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货