用VB进行GDI+绘图

正巧处理图形,突然发现一个很强的库GDI+,遂恶补一番!

 

VERSION 5.00
Begin VB.Form frmMain
   BackColor       =   &H8000000A&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "品雅图片转换工具  Ver 2.0        (Power By 赵洪涛 2008.12    Email:[e-mail])"
   ClientHeight    =   7590
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9480
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   379.5
   ScaleMode       =   2  'Point
   ScaleWidth      =   474
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1
      BackColor       =   &H8000000A&
      Caption         =   " 选项设置 "
      Height          =   1455
      Left            =   240
      TabIndex        =   5
      Top             =   240
      Width           =   9015
      Begin VB.ComboBox Combo1
         Height          =   300
         ItemData        =   "Form1.frx":0000
         Left            =   6240
         List            =   "Form1.frx":000D
         Style           =   2  'Dropdown List
         TabIndex        =   21
         Top             =   1027
         Width           =   855
      End
      Begin VB.CommandButton Command4
         BackColor       =   &H00FFFFFF&
         Caption         =   "清除"
         Height          =   375
         Left            =   4080
         Style           =   1  'Graphical
         TabIndex        =   20
         ToolTipText     =   "从列表中移除选定的项"
         Top             =   990
         Width           =   855
      End
      Begin VB.CommandButton Command2
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFFFF&
         Caption         =   "选择图片"
         Height          =   375
         Left            =   3120
         Style           =   1  'Graphical
         TabIndex        =   19
         ToolTipText     =   "插入新图片"
         Top             =   990
         Width           =   855
      End
      Begin VB.CommandButton Command1
         Caption         =   "开始转换 ...(&C)"
         Height          =   375
         Left            =   7275
         TabIndex        =   0
         Top             =   990
         Width           =   1575
      End
      Begin VB.TextBox Text3
         Enabled         =   0   'False
         Height          =   270
         Left            =   5760
         MaxLength       =   4
         TabIndex        =   2
         Text            =   "768"
         Top             =   225
         Width           =   615
      End
      Begin VB.TextBox Text2
         Enabled         =   0   'False
         Height          =   270
         Left            =   3720
         MaxLength       =   4
         TabIndex        =   1
         Text            =   "1024"
         Top             =   225
         Width           =   615
      End
      Begin VB.OptionButton Option4
         BackColor       =   &H8000000A&
         Caption         =   "保持原大小，不进行缩放"
         Height          =   255
         Left            =   240
         TabIndex        =   10
         Top             =   1110
         Value           =   -1  'True
         Width           =   2295
      End
      Begin VB.OptionButton Option3
         BackColor       =   &H8000000A&
         Caption         =   "自定义尺寸进行等比缩放"
         Height          =   255
         Left            =   240
         TabIndex        =   9
         Top             =   820
         Width           =   2295
      End
      Begin VB.OptionButton Option2
         BackColor       =   &H8000000A&
         Caption         =   "以高度为准进行等比缩放"
         Height          =   255
         Left            =   240
         TabIndex        =   8
         Top             =   530
         Width           =   2295
      End
      Begin VB.OptionButton Option1
         BackColor       =   &H8000000A&
         Caption         =   "以宽度为准进行等比缩放"
         Height          =   255
         Left            =   240
         TabIndex        =   7
         Top             =   240
         Width           =   2295
      End
      Begin VB.TextBox Text1
         Height          =   270
         Left            =   8010
         MaxLength       =   3
         TabIndex        =   3
         Text            =   "80"
         Top             =   225
         Width           =   615
      End
      Begin VB.Label Label10
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "转换成："
         ForeColor       =   &H00FF0000&
         Height          =   180
         Left            =   5490
         TabIndex        =   22
         Top             =   1087
         Width           =   720
      End
      Begin VB.Label Label4
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "0 %"
         ForeColor       =   &H0000FFFF&
         Height          =   180
         Left            =   5880
         TabIndex        =   16
         Top             =   645
         Width           =   270
      End
      Begin VB.Label Label3
         BackColor       =   &H00FF0000&
         Height          =   315
         Left            =   3135
         TabIndex        =   17
         Top             =   585
         Width           =   15
      End
      Begin VB.Label Label9
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "%"
         ForeColor       =   &H00404040&
         Height          =   180
         Left            =   8760
         TabIndex        =   15
         Top             =   270
         Width           =   90
      End
      Begin VB.Label Label8
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "像素"
         ForeColor       =   &H00404040&
         Height          =   180
         Left            =   6420
         TabIndex        =   14
         Top             =   270
         Width           =   360
      End
      Begin VB.Label Label7
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "高度："
         ForeColor       =   &H00FF0000&
         Height          =   180
         Left            =   5160
         TabIndex        =   13
         Top             =   270
         Width           =   540
      End
      Begin VB.Label Label6
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "像素"
         ForeColor       =   &H00404040&
         Height          =   180
         Left            =   4380
         TabIndex        =   12
         Top             =   270
         Width           =   360
      End
      Begin VB.Label Label5
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "宽度："
         ForeColor       =   &H00FF0000&
         Height          =   180
         Left            =   3120
         TabIndex        =   11
         Top             =   270
         Width           =   540
      End
      Begin VB.Label Label2
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "清晰度："
         ForeColor       =   &H00FF0000&
         Height          =   180
         Left            =   7200
         TabIndex        =   6
         Top             =   270
         Width           =   720
      End
      Begin VB.Label Label1
         Appearance      =   0  'Flat
         BackColor       =   &H00808080&
         BorderStyle     =   1  'Fixed Single
         ForeColor       =   &H80000008&
         Height          =   345
         Left            =   3120
         TabIndex        =   18
         Top             =   570
         Width           =   5730
      End
   End
   Begin VB.ListBox List1
      Height          =   5460
      Left            =   240
      MultiSelect     =   2  'Extended
      TabIndex        =   4
      Top             =   1920
      Width           =   9015
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

 
Private Type OPENFILENAME
     lStructSize As Long
     hwndOwner As Long
     hInstance As Long
     lpstrFilter As String
     lpstrCustomFilter As String
     nMaxCustFilter As Long
     nFilterIndex As Long
     lpstrFile As String
     nMaxFile As Long
     lpstrFileTitle As String
     nMaxFileTitle As Long
     lpstrInitialDir As String
     lpstrTitle As String
     flags As Long
     nFileOffset As Integer
     nFileExtension As Integer
     lpstrDefExt As String
     lCustData As Long
     lpfnHook As Long
     lpTemplateName As String
End Type

 

Private Type DlgFileInfo
    iCount As Long
    sPath As String
    sFile() As String
    picType() As Integer
End Type
 
Private Type GUID ' 16 bytes (128 bits)
    dwData1 As Long ' 4 bytes
    wData2 As Integer ' 2 bytes
    wData3 As Integer ' 2 bytes
    abData4(7) As Byte ' 8 bytes, zero based
End Type

 
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End Type
 
 Private Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type
 
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
 
Public Enum GpUnit  ' aka Unit
   UnitWorld      ' 0 -- World coordinate (non-physical unit)
   UnitDisplay    ' 1 -- Variable -- for PageTransform only
   UnitPixel      ' 2 -- Each unit is one device pixel.
   UnitPoint      ' 3 -- Each unit is a printer's point, or 1/72 inch.
   UnitInch       ' 4 -- Each unit is 1 inch.
   UnitDocument   ' 5 -- Each unit is 1/300 inch.
   UnitMillimeter ' 6 -- Each unit is 1 millimeter.
End Enum
 
Public Enum GpStatus  'Status
    ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
End Enum
 
Public Enum GpPixelFormat
'    PixelFormat1bppIndexed = &H30101
'    PixelFormat4bppIndexed = &H30402
'    PixelFormat8bppIndexed = &H30803
'    PixelFormat16bppGreyScale = &H101004
'    PixelFormat16bppRGB555 = &H21005
'    PixelFormat16bppRGB565 = &H21006
'    PixelFormat16bppARGB1555 = &H61007
    PixelFormat24bppRGB = &H21808
'    PixelFormat32bppRGB = &H22009
'    PixelFormat32bppARGB = &H26200A
'    PixelFormat32bppPARGB = &HE200B
'    PixelFormat48bppRGB = &H10300C
'    PixelFormat64bppARGB = &H34400D
'    PixelFormat64bppPARGB = &H1C400E
End Enum
Dim cPicPath As String

 

Private Const OFN_READONLY = &H1                     '“以只读方式”为选中
Private Const OFN_OVERWRITEPROMPT = &H2              '隐藏“以只读方式”
Private Const OFN_HIDEREADONLY = &H4                 '出现“是否覆盖”对话框
Private Const OFN_NOCHANGEDIR = &H8                  '不能改变目录
Private Const OFN_SHOWHELP = &H10                    '显示“帮助”
Private Const OFN_ENABLEHOOK = &H20                  '使对话框钩子函数生效
Private Const OFN_ENABLETEMPLATE = &H40              '模板生效
Private Const OFN_ENABLETEMPLATEHANDLE = &H80        '模板句柄生效？？
Private Const OFN_NOVALIDATE = &H100                 '允许非法字符
Private Const OFN_ALLOWMULTISELECT = &H200           '允许选择多个文件
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800              '路径必须存在
Private Const OFN_FILEMUSTEXIST = &H1000             '文件必须存在
Private Const OFN_CREATEPROMPT = &H2000              '出现“是否建立文件”对话框
Private Const OFN_SHAREAWARE = &H4000                '忽略共享冲突
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000         '不进行文件创建测试
Private Const OFN_NONETWORKBUTTON = &H20000          '没有网络按键（旧风格专用）
Private Const OFN_NOLONGNAMES = &H40000              '不使用长文件名（旧风格专用）
Private Const OFN_EXPLORER = &H80000                 '资源管理器风格（新风格）
Private Const OFN_NODEREFERENCELINKS = &H100000      '使*.lnk可以选中
Private Const OFN_LONGNAMES = &H200000               '使用长文件名（旧风格专用）
Private Const OFN_ENABLEINCLUDENOTIFY = &H400000     '准许包括通知？？
Private Const OFN_ENABLESIZING = &H800000            '可改变大小
Private Const OFN_USEMONIKERS = &H1000000
Private Const OFN_DONTADDTORECENT = &H2000000
Private Const OFN_FORCESHOWHIDDEN = &H10000000

Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (imageattr As Long) As GpStatus
Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As GpStatus
 
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
Private Declare Function GdipDrawImageRectRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal dstx As Single, ByVal dsty As Single, ByVal dstwidth As Single, ByVal dstheight As Single, ByVal SrcX As Single, ByVal SrcY As Single, ByVal srcwidth As Single, ByVal srcheight As Single, ByVal srcUnit As GpUnit, Optional ByVal imageAttributes As Long = 0, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As GpStatus
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, bitmap As Long) As GpStatus
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As GpStatus
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, ByRef graphics As Long) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, image As Long) As GpStatus
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal image As Long, ByRef Width As Single, ByRef Height As Single) As GpStatus

Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As GpStatus

 

 

Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Function GetDlgSelectFileInfo(strFilename As String) As DlgFileInfo
    
    '思路： 用CommonDialog控件选择文件后，其Filename属性值如下：
    '       1、如果选择的是"C:/Test.txt"，  Filename="C:/Test.txt"，    CurDir()="C:/"
    '       2、如果选择的是"C:/1/Test.txt"，Filename="C:/1/Test.txt"，  CurDir()="C:/1"
    '       3、如果选择的是"C:/1.txt"和"C:/2.txt"，则：
    '                                   Filename="C:/1 1.txt 2.txt"，  CurDir()="C:/1"
    '       因此先将路径分离开，再利用多文件之间插入的Chr$(0)字符分解各个文件名即可。
    
    Dim sPath, tmpStr As String
    Dim sFile() As String
    Dim iCount As Integer
    Dim i As Integer, n As Integer, nOld As Integer
    
    tmpStr = Trim(strFilename)
    If Len(tmpStr) = 1 Then Exit Function
    
    i = 1
    nOld = 0
    n = 1
    
    Do While i > 0
        n = InStr(nOld + 1, tmpStr, Chr$(0), vbBinaryCompare)
        If n - nOld > 1 Then
            iCount = iCount + 1
            ReDim Preserve sFile(iCount)
            sFile(iCount) = Mid$(tmpStr, nOld + 1, n - nOld - 1)
            nOld = n
        Else
            i = 0
        End If
    Loop
    
    If iCount <> 1 Then Exit Function
    
    If iCount = 1 Then
        n = InStrRev(sFile(1), "/")
        
        GetDlgSelectFileInfo.iCount = 1
        GetDlgSelectFileInfo.sPath = Mid(sFile(1), 1, n)
        
        ReDim GetDlgSelectFileInfo.sFile(1)
        GetDlgSelectFileInfo.sFile(1) = Mid(sFile(1), n + 1)
        ReDim GetDlgSelectFileInfo.picType(1)
        Select Case UCase(Right(GetDlgSelectFileInfo.sFile(1), 4))
            Case ".BMP"
                GetDlgSelectFileInfo.picType(1) = 1
            Case ".GIF"
                GetDlgSelectFileInfo.picType(1) = 2
            Case Else
                GetDlgSelectFileInfo.picType(1) = 3
        End Select
    Else
        GetDlgSelectFileInfo.iCount = iCount - 1
        ReDim GetDlgSelectFileInfo.sFile(iCount - 1)
        ReDim GetDlgSelectFileInfo.picType(iCount - 1)
        
        If Right$(sFile(1), 1) <> "/" Then sFile(1) = sFile(1) & "/"
        GetDlgSelectFileInfo.sPath = sFile(1)
        
        For i = 2 To iCount
            GetDlgSelectFileInfo.sFile(i - 1) = sFile(i)
            Select Case UCase(Right(GetDlgSelectFileInfo.sFile(i - 1), 4))
                Case ".BMP"
                    GetDlgSelectFileInfo.picType(i - 1) = 1
                Case ".GIF"
                    GetDlgSelectFileInfo.picType(i - 1) = 2
                Case Else
                    GetDlgSelectFileInfo.picType(i - 1) = 3
            End Select
        Next i
    End If
End Function

 

 

 

 
'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    SavePic
'**    输    入 ：    pic(StdPicture)        -   图象句柄
'**             ：    FileName(String)       -   保存路径
'**             ：    Quality(Byte)          -   JPG图象质量
'**             ：    TIFF_ColorDepth(Long)  -   TTF格式的颜色深度
'**             ：    TIFF_Compression(Long) -   TTF格式的压缩比
'**    输    出 ：    无
'**    功能描述 ：    把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'**    日    期 ：
'**    修 改 人 ：    laviewpbt
'**    日    期 ：    2005-10-23 14.43.52
'**    版    本 ：    Version 1.2.1
'*************************************************************************
Private Sub SavePic(ByVal pict As String, ByVal FileName As String, picType As String, _
                    Optional ByVal Quality As Byte = 80, _
                    Optional ByVal TIFF_ColorDepth As Long = 24, _
                    Optional ByVal TIFF_Compression As Long = 6)
                    
 
   Dim tSI As GdiplusStartupInput
   Dim lRes As Long
   Dim lGDIP As Long
   Dim lBitmap As Long
   Dim aEncParams() As Byte
   
   Screen.MousePointer = vbHourglass
   
'   On Error GoTo ErrHandle:
   
   tSI.GdiplusVersion = 1   ' 初始化 GDI+
   lRes = GdiplusStartup(lGDIP, tSI)
 
    If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
'      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
        lRes = GdipLoadImageFromFile(StrPtr(pict), lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters    '初始化解码器的GUID标识
            
            Select Case picType
                Case "jpg"
                   CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                   tParams.count = 1                               ' 设置解码器参数
                   With tParams.Parameter ' Quality
                      CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识
                      .NumberOfValues = 1
                      .type = 4
                      .Value = VarPtr(Quality)
                   End With
                   
                   ReDim aEncParams(1 To Len(tParams))
                   Call CopyMemory(aEncParams(1), tParams, Len(tParams))
                   
               Case "png"
                    CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                    ReDim aEncParams(1 To Len(tParams))
                    
               Case "gif"
                    CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                    ReDim aEncParams(1 To Len(tParams))
            End Select
                   
            If Option4.Value Then   '不缩放
                lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像
            Else
                Dim nW As Single, nH As Single, nBL As Single   '原始宽、高、比例
                Dim nCurrW As Integer, nCurrH As Integer    '新的宽、高
                Dim GDICopyBitmap As Long, GDIGraphics As Long
                
                Dim nTmpW As Integer, nTmpH As Integer, ImgAttr As Long
                
                If GdipGetImageDimension(lBitmap, nW, nH) = 0 Then
                   '''''''''''''''''''''''不执行'''''''
                    If Option1.Value Then
                        nBL = nW / CInt(Text2.Text)
                        nCurrW = CInt(Text2.Text)
                        nCurrH = CInt(nH / nBL)
                                            
                        Call GdipCreateBitmapFromScan0(nCurrW, nCurrH, 0, PixelFormat24bppRGB, ByVal 0&, GDICopyBitmap)
                        Call GdipGetImageGraphicsContext(GDICopyBitmap, GDIGraphics)
                        Call GdipDrawImageRect(GDIGraphics, lBitmap, 0, 0, nCurrW, nCurrH)
                    End If
                    
                    If Option2.Value Then
                        nBL = nH / CInt(Text3.Text)
                        nCurrW = CInt(nW / nBL)
                        nCurrH = CInt(Text3.Text)
                        
                        Call GdipCreateBitmapFromScan0(nCurrW, nCurrH, 0, PixelFormat24bppRGB, ByVal 0&, GDICopyBitmap)
                        Call GdipGetImageGraphicsContext(GDICopyBitmap, GDIGraphics)
                        Call GdipDrawImageRect(GDIGraphics, lBitmap, 0, 0, nCurrW, nCurrH)
                    End If
                    ''''''''''''''''''''不执行'''''''''
                   
                    '自定义尺寸进行等比缩放
                    If Option3.Value Then
                        If (nW / CInt(Text2.Text)) > (nH / CInt(Text3.Text)) Then
                            nBL = nW / CInt(Text2.Text)
                            nCurrW = CInt(Text2.Text)
                            nCurrH = CInt(nH / nBL)
                        Else
                            nBL = nH / CInt(Text3.Text)
                            nCurrW = CInt(nW / nBL)
                            nCurrH = CInt(Text3.Text)
                        End If
                        
                        nTmpW = CLng(Text2.Text)
                        nTmpH = CLng(Text3.Text)
                        
                        Call GdipCreateBitmapFromScan0(nTmpW, nTmpH, 0, PixelFormat24bppRGB, ByVal 0&, GDICopyBitmap)
                       ' Call GdipCreateImageAttributes(ImgAttr)
                        Call GdipGetImageGraphicsContext(GDICopyBitmap, GDIGraphics)
                        GdipGraphicsClear GDIGraphics, &HFFFFFFFF
                      
                        GdipDrawImageRect GDIGraphics, lBitmap, 0, 0, nTmpW, nTmpH  '拉伸到100*200

                        'Call GdipDisposeImageAttributes(ImgAttr)
                    End If
                        
                    Call GdipSaveImageToFile(GDICopyBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))
                    
                    Call GdipDisposeImage(GDICopyBitmap)
                    Call GdipDeleteGraphics(GDIGraphics)
                End If
            End If
              
            GdipDisposeImage lBitmap       ' 销毁GDI+图像
        End If
        
        GdiplusShutdown lGDIP              '销毁 GDI+
    End If
   
    Screen.MousePointer = vbDefault
    Erase aEncParams
    Exit Sub
   
ErrHandle:
    Screen.MousePointer = vbDefault
    MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号:  " & Err.Number & vbCrLf & "错误描述:  " & Err.Description, vbInformation Or vbOKOnly, "错误"
End Sub
 
Private Sub Combo1_Click()
    If Combo1.ListIndex > 0 Then
        Text1.Enabled = False
    Else
        Text1.Enabled = True
    End If
End Sub

 
Private Sub Command1_Click()
    If List1.ListCount < 1 Then
        MsgBox "请选择要转换的图片文件！", 0 + 48, "错误信息"
        Command2.SetFocus
        Exit Sub
    End If
    
    Command1.Enabled = False
    Command2.Enabled = False
    Command4.Enabled = False
    
    Text1.Enabled = False
    Combo1.Enabled = False
    
    Dim i As Integer, cTmp As String, nQuality As Byte
    
    nQuality = CInt(Text1.Text)
    
    For i = 1 To List1.ListCount
        cTmp = Left(List1.List(i - 1), Len(List1.List(i - 1)) - 4)
        
        If Dir(cTmp & "_pview." & LCase(Combo1.Text)) <> "" Then
            Kill cTmp & "_pview." & LCase(Combo1.Text)
        End If
        
        DoEvents
'        Call SavePic(LoadPicture(cPicPath & List1.List(i)), cPicPath & cTmp & "_pview.jpg", ".jpg", CcInt(Text1.Text))
        Call SavePic(List1.List(i - 1), cTmp & "_pview." & LCase(Combo1.Text), LCase(Combo1.Text), nQuality)
        
        Label4.Caption = CInt(i / (List1.ListCount) * 100) & " %"
        Label3.Width = CInt(i / (List1.ListCount) * 5700)
        DoEvents
    Next i
    
    MsgBox "共转换了 " & List1.ListCount & " 个图片 ！", 0 + 64, "提示信息"
    
    Label4.Caption = "0 %"
    Label3.Width = 0
    
    Text1.Enabled = True
    Combo1.Enabled = True
    Command1.Enabled = True
    Command2.Enabled = True
    Command4.Enabled = True
End Sub
 
Private Sub Command2_Click()
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long, n As Integer
    Static strFilter As String
    Dim cTmp As String
   
    strFilter = "All Pictures" & Chr(0) & "*.bmp;*.gif;*.jpg;*.jpeg;*.tif;*.png" & Chr(0) & _
    "Bitmap (*.bmp)" & Chr(0) & "*.bmp" & Chr(0) & _
    "GIF (*.gif)" & Chr(0) & "*.gif" & Chr(0) & _
    "JPG (*.jpg;*.jpeg)" & Chr(0) & "*.jpg;*.jpeg" & Chr(0) & _
    "TIF (*.tif)" & Chr(0) & "*.tif" & Chr(0) & _
    "PNG (*.png)" & Chr(0) & "*.png" & Chr(0)
    
     OpenFile.lStructSize = Len(OpenFile)
     OpenFile.hwndOwner = Me.hwnd
     OpenFile.hInstance = App.hInstance
     OpenFile.lpstrFilter = strFilter
     OpenFile.nFilterIndex = 1
     OpenFile.lpstrFile = String(8192, 0)
     OpenFile.nMaxFile = 8192
     OpenFile.lpstrFileTitle = Space(254)
     OpenFile.nMaxFileTitle = 255
     OpenFile.lpstrInitialDir = cPicPath
     OpenFile.lpstrTitle = "选择文本文件"
     OpenFile.flags = OFN_LONGNAMES Or OFN_NODEREFERENCELINKS Or OFN_EXPLORER Or OFN_HIDEREADONLY Or _
        OFN_ENABLESIZING Or OFN_ALLOWMULTISELECT Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
     
     lReturn = GetOpenFileName(OpenFile)
    
     n = GetDlgSelectFileInfo(OpenFile.lpstrFile).iCount
     If n > 0 Then
'        If cPicPath <> GetDlgSelectFileInfo(OpenFile.lpstrFile).sPath Then
'            List1.Clear
'        End If
     
        cPicPath = GetDlgSelectFileInfo(OpenFile.lpstrFile).sPath
        
        For lReturn = 1 To n
            List1.AddItem cPicPath & GetDlgSelectFileInfo(OpenFile.lpstrFile).sFile(lReturn)
        Next
     End If
End Sub
 
Private Sub Command4_Click()
    If List1.ListCount = 1 Then Exit Sub
    Dim i As Integer
    For i = List1.ListCount - 1 To 0 Step -1
        If List1.Selected(i) Then
            List1.RemoveItem i
        End If
    Next i
End Sub
 
Private Sub Form_Initialize()
    Combo1.ListIndex = 0
End Sub
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{Tab}"
    End If
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'Unload Form1
End Sub
 
Private Sub List1_Click()
    If List1.ListCount < 1 Then Exit Sub
    
    Dim w As Single, h As Single
    Dim nB As Single, nB1 As Single, i As Integer
    Dim gdip_Graphics As Long, gdip_Image As Long
    Dim tSI As GdiplusStartupInput, lRes As Long, lGDIP As Long
    Dim nCurrX As Integer, nCurrY As Integer
    

 
    tSI.GdiplusVersion = 1   ' 初始化 GDI+
    lRes = GdiplusStartup(lGDIP, tSI)
    If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
        lRes = GdipCreateFromHDC(Me.hdc, gdip_Graphics)
        If lRes = 0 Then
            lRes = GdipLoadImageFromFile(StrPtr(List1.Text), gdip_Image)
            If lRes = 0 Then
                Call GdipGetImageDimension(gdip_Image, w, h)
                If Option1.Value Then
                    Me.Label6.Caption = "转前：" & w & " X " & h & " 像素   转后：" & Text2.Text & " X " & Int(h / w * CInt(Text2.Text)) & " 像素"
                End If
                
                If Option2.Value Then
                    Me.Label6.Caption = "转前：" & w & " X " & h & " 像素   转后：" & Int(w / h * CInt(Text3.Text)) & " X " & Text3.Text & " 像素"
                End If
                
                If Option3.Value Then
                    Me.Label6.Caption = "转前：" & w & " X " & h & " 像素   转后：" & Text2.Text & " X " & Text3.Text & " 像素"
                End If
                
                If Option4.Value Then
                    Me.Label6.Caption = "转前：" & w & " X " & h & " 像素   转后：" & w & " X " & h & " 像素"
                End If
                
                Me.Label6.Left = (Me.Width / 15 - Me.Label6.Width) / 2
                If w = 284 And h = 164 Then
                    nCurrX = List1.Left + List1.Width - w
                    nCurrY = List1.Top + List1.Height - h
                    Call GdipDrawImageRect(gdip_Graphics, gdip_Image, Int((284 - w) / 2) + 1, Int((164 - h) / 2) + 1, w, h)
                Else
                    nB = 284 / w
                    nB1 = 164 / h
                    
                    If nB > nB1 Then
                        Call GdipDrawImageRect(gdip_Graphics, gdip_Image, 1, Int((164 - h * nB) / 2) + 1, 284, Int(h * nB))
                    Else
                        Call GdipDrawImageRect(gdip_Graphics, gdip_Image, Int((284 - w * nB1) / 2) + 1, 1, Int(w * nB1), 164)
                    End If
                End If
                Call GdipDisposeImage(gdip_Image)
            End If
            Call GdipDeleteGraphics(gdip_Graphics)
        End If
        GdiplusShutdown lGDIP              '销毁 GDI+
    End If
 
    Me.Refresh

End Sub
 
Private Sub Option1_Click()
    Call CheckOption
End Sub
 
Private Sub Option2_Click()
    Call CheckOption
End Sub
 
Private Sub Option3_Click()
    Call CheckOption
End Sub
 
Private Sub Option4_Click()
    Call CheckOption
End Sub
 
Private Sub Text1_Validate(Cancel As Boolean)
    Call CheckText(Text1, 80, 10, 100)
End Sub
 
Private Sub Text2_Validate(Cancel As Boolean)
    Call CheckText(Text2, 1024, 10, 2560)
End Sub
 
Private Sub Text3_Validate(Cancel As Boolean)
    Call CheckText(Text3, 768, 10, 1600)
End Sub
 
Function CheckText(oTxt As TextBox, nDef As Integer, nMin As Integer, nMax As Integer)
    Dim cTmp As String
    
    cTmp = Trim(oTxt.Text)
    
    If cTmp = "" Then
        oTxt.Text = nDef
        Exit Function
    End If
    
    If Not IsNumeric(cTmp) Then
        oTxt.Text = nDef
        Exit Function
    End If
    
    If CInt(cTmp) < nMin Or CInt(cTmp) > nMax Then
        oTxt.Text = nDef
        Exit Function
    End If
End Function
 
Function CheckOption()
 
    If Option1.Value Then
        Text2.Enabled = True
        Text3.Enabled = False
        Exit Function
    End If
    
    If Option2.Value Then
        Text2.Enabled = False
        Text3.Enabled = True
        Exit Function
    End If
    
    If Option3.Value Then
        Text2.Enabled = True
        Text3.Enabled = True
        Exit Function
    End If
    
    If Option4.Value Then
        Text2.Enabled = False
        Text3.Enabled = False
        Exit Function
    End If
End Function