以下代码是缩小图片,但缩小后图片色彩严重失真,代码错在哪儿,请高人帮忙指正。
'以下在.Bas
Option Explicit
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 Long) As LongDeclare 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 LongConst SRCCOPY = &HCC0020Public Sub DrawBitMap(Dst As Object, ByVal xRate As Double, _
ByVal yRate As Double, ByVal FileName As String)
Dim dstWidth As Long, dstHeight As Long
Dim srcWidth As Long, srcHeight As Long
Dim x As Long, y As Long
Dim pic As StdPicture
Dim hDc5 As Long, i As LongSet pic = LoadPicture(FileName) '读取图形档hDc5 = CreateCompatibleDC(0) '建立Memory DC
i = SelectObject(hDc5, pic.Handle) '在该memoryDC上放上bitmap图srcHeight = Dst.ScaleY(pic.Height, vbHimetric, vbPixels)
srcWidth = Dst.ScaleX(pic.Width, vbHimetric, vbPixels)dstHeight = CLng(srcHeight * yRate)
If dstHeight < 0 Then
y = -1 * dstHeight
Else
y = 0
End If
dstWidth = CLng(srcWidth * xRate)
If dstWidth < 0 Then
x = -1 * dstWidth
Else
x = 0
End If
Call StretchBlt(Dst.hdc, x, y, dstWidth, dstHeight, hDc5, 0, 0, srcWidth, srcHeight, SRCCOPY)
Call DeleteDC(hDc5)
End Sub
Public Sub DrawPicture(Dst As Object, ByVal xRate As Double, _
ByVal yRate As Double, ByVal FileName As String)
Dim dstWidth As Long, dstHeight As Long
Dim srcWidth As Long, srcHeight As Long
Dim x As Long, y As Long
Dim pic As StdPicture
Dim i As LongSet pic = LoadPicture(FileName) '读取图形档srcHeight = Dst.ScaleY(pic.Height, vbHimetric, vbPixels)
srcWidth = Dst.ScaleX(pic.Width, vbHimetric, vbPixels)dstHeight = CLng(srcHeight * yRate)
If dstHeight < 0 Then
y = -1 * dstHeight
Else
y = 0
End If
dstWidth = CLng(srcWidth * xRate)
If dstWidth < 0 Then
x = -1 * dstWidth
Else
x = 0
End If
Dst.ScaleMode = 3
Dst.PaintPicture pic, x, y, dstWidth, dstHeight, 0, 0, srcWidth, srcHeightEnd Sub
'以下在Form需两个command button一个PictureBoxPrivate Sub Command2_Click()
Call DrawBitMap(Picture1, 0.5, 0.5, "c:\tt.bmp") '将原图片缩小0.5倍
End Sub
'以下在.Bas
Option Explicit
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 Long) As LongDeclare 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 LongConst SRCCOPY = &HCC0020Public Sub DrawBitMap(Dst As Object, ByVal xRate As Double, _
ByVal yRate As Double, ByVal FileName As String)
Dim dstWidth As Long, dstHeight As Long
Dim srcWidth As Long, srcHeight As Long
Dim x As Long, y As Long
Dim pic As StdPicture
Dim hDc5 As Long, i As LongSet pic = LoadPicture(FileName) '读取图形档hDc5 = CreateCompatibleDC(0) '建立Memory DC
i = SelectObject(hDc5, pic.Handle) '在该memoryDC上放上bitmap图srcHeight = Dst.ScaleY(pic.Height, vbHimetric, vbPixels)
srcWidth = Dst.ScaleX(pic.Width, vbHimetric, vbPixels)dstHeight = CLng(srcHeight * yRate)
If dstHeight < 0 Then
y = -1 * dstHeight
Else
y = 0
End If
dstWidth = CLng(srcWidth * xRate)
If dstWidth < 0 Then
x = -1 * dstWidth
Else
x = 0
End If
Call StretchBlt(Dst.hdc, x, y, dstWidth, dstHeight, hDc5, 0, 0, srcWidth, srcHeight, SRCCOPY)
Call DeleteDC(hDc5)
End Sub
Public Sub DrawPicture(Dst As Object, ByVal xRate As Double, _
ByVal yRate As Double, ByVal FileName As String)
Dim dstWidth As Long, dstHeight As Long
Dim srcWidth As Long, srcHeight As Long
Dim x As Long, y As Long
Dim pic As StdPicture
Dim i As LongSet pic = LoadPicture(FileName) '读取图形档srcHeight = Dst.ScaleY(pic.Height, vbHimetric, vbPixels)
srcWidth = Dst.ScaleX(pic.Width, vbHimetric, vbPixels)dstHeight = CLng(srcHeight * yRate)
If dstHeight < 0 Then
y = -1 * dstHeight
Else
y = 0
End If
dstWidth = CLng(srcWidth * xRate)
If dstWidth < 0 Then
x = -1 * dstWidth
Else
x = 0
End If
Dst.ScaleMode = 3
Dst.PaintPicture pic, x, y, dstWidth, dstHeight, 0, 0, srcWidth, srcHeightEnd Sub
'以下在Form需两个command button一个PictureBoxPrivate Sub Command2_Click()
Call DrawBitMap(Picture1, 0.5, 0.5, "c:\tt.bmp") '将原图片缩小0.5倍
End Sub
解决方案 »
- 怎么判断一个长整型变量在两个数值范围内?主要是因为所判断的数值太大,在系统中溢出了
- 继续请教:用VB打开外部的EXE文件,如何得到打开的窗体标题?
- 关于Timer控件的小问题
- 怎么独占的打开一个access数据库?也就是我打开这个数据库的时候,不允许其它任何人再打开它
- 关于installshield的问题,很急啊,有谁能帮帮我?解决不了就得……
- 这句程序有问题吗? If (Left$(st, 1) = """) and (right$(st,1)=""") Then
- A Q
- 请问,能不能用VB实现金山毒霸那种形式的界面?
- VB 怎样将字符串按2位 差分
- 兄弟们帮个小忙!
- VB翻译成JAVA, 各位大虾帮忙看看问题在哪
- 想请教一下数据库连接的问题
Option Explicit
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 Long) As LongDeclare 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 LongPrivate Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Const HALFTONE = 4Const SRCCOPY = &HCC0020Public Sub DrawBitMap(Dst As Object, ByVal xRate As Double, _
ByVal yRate As Double, ByVal FileName As String)
Dim dstWidth As Long, dstHeight As Long
Dim srcWidth As Long, srcHeight As Long
Dim x As Long, y As Long
Dim pic As StdPicture
Dim hDc5 As Long, i As LongSet pic = LoadPicture(FileName) '读取图形档hDc5 = CreateCompatibleDC(0) '建立Memory DC
i = SelectObject(hDc5, pic.Handle) '在该memoryDC上放上bitmap图srcHeight = Dst.ScaleY(pic.Height, vbHimetric, vbPixels)
srcWidth = Dst.ScaleX(pic.Width, vbHimetric, vbPixels)dstHeight = CLng(srcHeight * yRate)
If dstHeight < 0 Then
y = -1 * dstHeight
Else
y = 0
End If
dstWidth = CLng(srcWidth * xRate)
If dstWidth < 0 Then
x = -1 * dstWidth
Else
x = 0
End If
Call SetStretchBltMode(Dst.hdc, HALFTONE)
Call StretchBlt(Dst.hdc, x, y, dstWidth, dstHeight, hDc5, 0, 0, srcWidth, srcHeight, SRCCOPY)
Call DeleteDC(hDc5)
End Sub
Public Sub DrawPicture(Dst As Object, ByVal xRate As Double, _
ByVal yRate As Double, ByVal FileName As String)
Dim dstWidth As Long, dstHeight As Long
Dim srcWidth As Long, srcHeight As Long
Dim x As Long, y As Long
Dim pic As StdPicture
Dim i As LongSet pic = LoadPicture(FileName) '读取图形档srcHeight = Dst.ScaleY(pic.Height, vbHimetric, vbPixels)
srcWidth = Dst.ScaleX(pic.Width, vbHimetric, vbPixels)dstHeight = CLng(srcHeight * yRate)
If dstHeight < 0 Then
y = -1 * dstHeight
Else
y = 0
End If
dstWidth = CLng(srcWidth * xRate)
If dstWidth < 0 Then
x = -1 * dstWidth
Else
x = 0
End If
Dst.ScaleMode = 3
Dst.PaintPicture pic, x, y, dstWidth, dstHeight, 0, 0, srcWidth, srcHeightEnd SubOption Explicit'以下在Form需两个command button一个PictureBoxPrivate Sub Command2_Click()
Call DrawBitMap(Picture1, 0.5, 0.5, "c:\tt.bmp") '将原图片缩小0.5倍
End Sub
'以下代码仅供参考
'将picture1中的图片缩放为picture2的宽度和高度后,保存为文件 D:\001.bmpOption Explicit
'Form1上添加一个Command1,2个图片框picture1,picture2
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 Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Const HALFTONE = 4
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = sourcePrivate Sub Command1_Click()
Dim Rtn As Long
Dim hDC1 As Long, hDC2 As Long
hDC1 = Picture1.hdc
hDC2 = Picture2.hdc
Call SetStretchBltMode(hDC2, HALFTONE)
Rtn = StretchBlt(hDC2, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, hDC1, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, SRCCOPY)
SavePicture Picture2.Image, "D:\001.bmp"
End SubPrivate Sub Form_Load()
Me.ScaleMode = 3
Picture2.AutoRedraw = True
Picture1.Picture = LoadPicture("C:\TT.BMP")
End Sub
Picture1.Picture = LoadPicture("c:\fw.bmp")
Picture1.AutoRedraw = True
Picture1.BorderStyle = 0
Picture1.AutoSize = True
Picture2.AutoRedraw = True
Picture2.BorderStyle = 0
End SubPrivate Sub Command1_Click()
Picture2.Width = Picture1.Width \ 2: Picture2.Height = Picture1.Height \ 2
Picture2.Cls
Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width \ 2, Picture1.Height \ 2
SavePicture Picture2.Image, "c:\kkk.bmp"
MsgBox "保存完成"
End Sub'**************************** StretchBlt 的动画演示
'添加 Picture1 Picture2 Timer1Option Explicit
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 Long) As Long
Dim DeductW&, SizeB As Boolean
Private Sub Form_Load()
Me.Width = 9000: Me.Height = 5200
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
Me.Caption = "CBM666的StretchBlt演示"
Picture1.ScaleMode = 3
Picture1.AutoSize = True
Picture1.AutoRedraw = True
Picture1.Picture = LoadPicture("c:\fw.bmp")
Picture1.Move (Me.Width - Picture1.Width) \ 2, 100
Picture2.Width = Picture1.Width: Picture2.Height = Picture1.Height
Picture2.Move Picture1.Left, Picture1.Top + Picture1.Height + 100
Picture2.AutoRedraw = True
Timer1.Interval = 10: Timer1.Enabled = True
End SubPrivate Sub Timer1_Timer()
DeductW = IIf(SizeB, DeductW - 1, DeductW + 1)
If SizeB = False Then
If DeductW = Picture1.ScaleWidth Then SizeB = True
Else
If DeductW <= 0 Then SizeB = False
End If
Picture2.Cls
StretchBlt Picture2.hdc, DeductW / 2, 0, Picture1.ScaleWidth - DeductW, Picture1.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, vbSrcCopy
End Sub
效果图:
http://p.blog.csdn.net/images/p_blog_csdn_net/cbm666/366646/o_fw.bmp
Dim transcolor$
Private Sub Form_Load()
transcolor = RGB(0, 0, 255) '透明色 = 蓝色
Picture1.BorderStyle = 0
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture1.Picture = LoadPicture("c:\fw.bmp")
Picture1.BackColor = transcolor
Picture2.ScaleMode = 3
Picture2.AutoRedraw = True
Picture2.BorderStyle = 0
Me.ScaleMode = 3
End SubPrivate Sub Picture1_Click()
Picture2.Width = Picture1.Width \ 4
Picture2.Height = Picture1.Height \ 4
GdiTransparentBlt Picture2.hDC, 0, 0, Picture2.Width, Picture2.Height, Picture1.hDC, 0, 0, Picture1.Width, Picture1.Height, transcolor
SavePicture Picture2.Image, "c:\kkk.bmp"
End Sub