以下代码是缩小图片,但缩小后图片色彩严重失真,代码错在哪儿,请高人帮忙指正。
'以下在.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

解决方案 »

  1.   

    模式变了,缩放时使用HALFTONE模式即可.
      

  2.   

    改成这样就对了:'以下在.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 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
      

  3.   

    '图片缩放,其实很简单,你写得太复杂了.参考一下我写的这个代码.希望对你有用!
    '以下代码仅供参考
    '将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
      

  4.   

    图片缩小使用PaintPicture不是很方便吗?'请将下图拷到你的 c:\fw.bmp'添加 Picture1 Picture2 Command1Private Sub Form_Load()
       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
      

  5.   

    '这是使用 GDI 的图片缩小保存, 并屏蔽透明色'添加Picture1,Picture2'将蓝色背景去除并缩小图片1/4尺寸,你自己的图片背景色自己改Private Declare Function GdiTransparentBlt Lib "gdi32" (ByVal hdc1 As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) As Long
    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