如何将一副比较大的图像缩小3倍以后变得更加逼真

Question

如何将一副比较大的图像缩小3倍以后变得更加逼真

Answer 1

用API函数StretchBlt以可以做到，并且可以设置放大或缩小的倍数。在网上搜一搜，有很多这方面的例子。

Answer 2

Option   Explicit Private   Declare   Function   GetDC   Lib   "user32"   (ByVal   hwnd   As   Long)   As   Long 
Private   Declare   Function   DeleteDC   Lib   "gdi32"   (ByVal   hdc   As   Long)   As   Long 
Private   Declare   Function   ReleaseDC   Lib   "user32"   (ByVal   hwnd   As   Long,   ByVal   hdc   As   Long)   As   Long 
Private   Declare   Function   CreateCompatibleDC   Lib   "gdi32"   (ByVal   hdc   As   Long)   As   Long 
Private   Declare   Function   CreateCompatibleBitmap   Lib   "gdi32"   (ByVal   hdc   As   Long,   ByVal   nWidth   As   Long,   ByVal   nHeight   As   Long)   As   Long 
Private   Declare   Function   CreateSolidBrush   Lib   "gdi32"   (ByVal   crColor   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   FillRect   Lib   "user32"   (ByVal   hdc   As   Long,   lpRect   As   RECT,   ByVal   hBrush   As   Long)   As   Long 
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   Declare   Function   OleCreatePictureIndirect   Lib   "olepro32.dll"   (lpPictDesc   As   PICTDESC,   riid   As   Any,   ByVal   fPictureOwnsHandle   As   Long,   IPic   As   IPicture)   As   Long Private   Const   STRETCH_ANDSCANS   =   1 
Private   Const   STRETCH_ORSCANS   =   2 
Private   Const   STRETCH_DELETESCANS   =   3 
Private   Const   STRETCH_HALFTONE   =   4 Private   Type   PICTDESC 
        Size                                 As   Long 
        Type                                 As   Long 
        hBmpOrIcon                     As   Long 
        hPal                                 As   Long 
End   Type Private   Type   RECT 
        Left                 As   Long 
        Top                   As   Long 
        Right               As   Long 
        Bottom             As   Long 
End   Type "   缩放图片 
"   参数：源图片,新的高度，新的宽度，是否保持长宽比(默认为保持比例)，保持长宽比时空白区域的填充颜色（默认为白色） 
Public   Function   StretchPicture(ByVal   Pic   As   StdPicture,   ByVal   NewWidth   As   Long,   ByVal   NewHeight   As   Long,   Optional   ByVal   KeepScale   As   Boolean   =   True,   Optional   ByVal   FillColor   As   OLE_COLOR   =   vbWhite)   As   StdPicture 
        
        Dim   lngW                         As   Long           "   原始图片宽度 
        Dim   lngH                         As   Long           "   原始图片高度 
        Dim   lngNewW                   As   Long           "   缩略图真实宽度 
        Dim   lngNewH                   As   Long           "   缩略图真实高度 
        Dim   lngHdc1                   As   Long           "   内存DC1 
        Dim   lngHdc2                   As   Long           "   内存DC2 
        Dim   lngHdcScreen         As   Long           "   屏幕DC 
        Dim   lngBmp                     As   Long           "   新的位图句柄 
        Dim   lngBmpOld1             As   Long           "   原始位图句柄1 
        Dim   lngBmpOld2             As   Long           "   原始位图句柄2 
        Dim   lngBrush                 As   Long           "   填充画刷 
        Dim   lngGuid(3)             As   Long 
        Dim   sngDW                       As   Single       "   宽度缩放比 
        Dim   sngDH                       As   Single       "   高度缩放比 
        Dim   objPic                     As   StdPicture 
        Dim   udtRect                   As   RECT 
        Dim   udtPictDesc           As   PICTDESC 
        
        "   计算原始图片宽度和高度 
        lngW   =   Pic.Width   *   1440   /   2540   /   Screen.TwipsPerPixelX 
        lngH   =   Pic.Height   *   1440   /   2540   /   Screen.TwipsPerPixelX 
        
        "   创建两个兼容于屏幕的内存DC 
        lngHdcScreen   =   GetDC(0) 
        
        lngHdc1   =   CreateCompatibleDC(lngHdcScreen) 
        lngHdc2   =   CreateCompatibleDC(lngHdcScreen) 
        
        "   创建新的位图 
        lngBmp   =   CreateCompatibleBitmap(lngHdcScreen,   NewWidth,   NewHeight) 
        
        "   将位图加入到DC中 
        lngBmpOld1   =   SelectObject(lngHdc1,   Pic.handle) 
        lngBmpOld2   =   SelectObject(lngHdc2,   lngBmp) 
        
        lngNewW   =   NewWidth 
        lngNewH   =   NewHeight 
        
        If   KeepScale   Then 
                
                "   设置缩略图背景色 
                udtRect.Right   =   NewWidth 
                udtRect.Bottom   =   NewHeight 
                
                lngBrush   =   CreateSolidBrush(FillColor) 
                FillRect   lngHdc2,   udtRect,   lngBrush 
                DeleteObject   lngBrush 
                
                "   计算长宽缩放比 
                sngDW   =   NewWidth   /   lngW 
                sngDH   =   NewHeight   /   lngH 
                
                "   缩放比使用较小的一个，计算实际图片大小 
                If   sngDW   <   sngDH   Then 
                        lngNewH   =   lngH   *   sngDW 
                Else 
                        lngNewW   =   lngW   *   sngDH 
                End   If 
                
        End   If 
        
        "   设置缩放模式，该模式将影响处理速度和生成图片的质量 
        SetStretchBltMode   lngHdc2,   STRETCH_HALFTONE 
        StretchBlt   lngHdc2,   (NewWidth   -   lngNewW)   /   2,   (NewHeight   -   lngNewH)   /   2,   lngNewW,   lngNewH,   lngHdc1,   0,   0,   lngW,   lngH,   vbSrcCopy 
        
        "   将位图转换成   StdPicture   对象 
        udtPictDesc.Size   =   Len(udtPictDesc) 
        udtPictDesc.Type   =   vbPicTypeBitmap 
        udtPictDesc.hBmpOrIcon   =   lngBmp 
        udtPictDesc.hPal   =   0 
        
        lngGuid(0)   =   &H7BF80980 
        lngGuid(1)   =   &H101ABF32 
        lngGuid(2)   =   &HAA00BB8B 
        lngGuid(3)   =   &HAB0C3000 
        
        OleCreatePictureIndirect   udtPictDesc,   lngGuid(0),   True,   objPic 
        
        SelectObject   lngHdc1,   lngBmpOld1 
        SelectObject   lngHdc2,   lngBmpOld2 
        
        "   释放GDI对象 
        DeleteDC   lngHdc1 
        DeleteDC   lngHdc2 
        ReleaseDC   0,   lngHdcScreen 
        
        Set   StretchPicture   =   objPic 
        
End   Function Private   Sub   Command1_Click() 
        
        Set   Picture2.Picture   =   StretchPicture(Picture1.Picture,   512,   512,   True,   vbBlack) 
                
End   Sub 

Answer 3

晕倒，楼上写的过程一个TransparentBlt不就可以了么，不用写那么一大段吧，效果还是一样的
而且楼主要的还不是这个，他要的只是StretchBlt

Answer 4

这段代码是我很久以前回答一个朋友的问题写的，用于生成缩略图。可以指定缩略图的大小，保持长宽比例，填充空白区域的颜色，直接输出Picture等。例如可以把任意一张图片缩放成32*32大小的图片,新图片的空白区域用黑色填充
set Picture2.Picture = StretchPicture(Picture1.Picture, 32, 32, True, vbBlack)

Answer 5

SavePicture Picture2.Picture,"c:\test.bmp"