设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

123下一页
返回列表 发新帖
查看: 6458|回复: 23
打印 上一主题 下一主题

[模块/函数] 保存StdPicture到JPG图片文件的函数

[复制链接]

点击这里给我发消息

跳转到指定楼层
1#
发表于 2008-1-5 16:40:21 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
Private Type Guid
        Data1   As Long
        Data2   As Integer
        Data3   As Integer
        Data4(0 To 7)       As Byte
  End Type
   
  Private Type GdiplusStartupInput
        GdiPlusVersion   As Long
        DebugEventCallback   As Long
        SuppressBackgroundThread   As Long
        SuppressExternalCodecs   As Long
  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 Declare Function GdiplusStartup Lib "gdiplus" ( _
        token As Long, _
        inputbuf As GdiplusStartupInput, _
        Optional ByVal outputbuf As Long = 0) As Long
   
  Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
        ByVal token As Long) As Long
   
  Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
        ByVal hbm As Long, _
        ByVal hpal As Long, _
        Bitmap As Long) As Long
   
  Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
        ByVal image As Long) As Long
   
  Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
        ByVal image As Long, _
        ByVal FileName As Long, _
        clsidEncoder As Guid, _
        encoderParams As Any) As Long
   
  Private Declare Function CLSIDFromString Lib "ole32" ( _
        ByVal str As Long, _
        id As Guid) As Long
   
  '   ----====   SaveJPG   ====----
   
  Public Sub SaveJPG( _
        ByVal pict As StdPicture, _
        ByVal FileName As String, _
        Optional ByVal quality As Byte = 80)
  Dim tSI     As GdiplusStartupInput
  Dim lRes     As Long
  Dim lGDIP     As Long
  Dim lBitmap     As Long
   
        '   Initialize   GDI+
        tSI.GdiPlusVersion = 1
        lRes = GdiplusStartup(lGDIP, tSI)
         
        If lRes = 0 Then
         
              '   Create   the   GDI+   bitmap
              '   from   the   image   handle
              lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
         
              If lRes = 0 Then
                    Dim tJpgEncoder     As Guid
                    Dim TParams     As EncoderParameters
                     
                    '   Initialize   the   encoder   GUID
                    CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
                                                    tJpgEncoder
               
                    '   Initialize   the   encoder   parameters
                    TParams.Count = 1
                    With TParams.Parameter     '   Quality
                          '   Set   the   Quality   GUID
                          CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB3505E7EB}"), .Guid
                          .NumberOfValues = 1
                          .type = 1
                          .Value = VarPtr(quality)
                    End With
                     
                    '   Save   the   image
                    lRes = GdipSaveImageToFile( _
                                      lBitmap, _
                                      StrPtr(FileName), _
                                      tJpgEncoder, _
                                      TParams)
                                                              
                    '   Destroy   the   bitmap
                    GdipDisposeImage lBitmap
                     
              End If
               
              '   Shutdown   GDI+
              GdiplusShutdown lGDIP
   
        End If
         
        If lRes Then
              Err.Raise 5, , "Cannot   save   the   image.   GDI+   Error:" & lRes
        End If
         
  End Sub
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖 订阅订阅
2#
发表于 2008-1-5 17:09:16 | 只看该作者
不错 , 收藏先
3#
发表于 2008-1-5 17:59:18 | 只看该作者
收藏
4#
发表于 2008-1-5 22:28:38 | 只看该作者
噢,cuxun兄ole automation这个不是自动引用的吗
5#
发表于 2008-1-5 22:31:17 | 只看该作者
收藏了
6#
发表于 2008-1-5 22:36:37 | 只看该作者
用了不少API函数,收藏~
7#
发表于 2008-1-5 22:52:24 | 只看该作者
对这个实在是不懂啊!!!

点击这里给我发消息

8#
发表于 2008-1-5 23:40:03 | 只看该作者
收藏......
9#
发表于 2008-1-7 20:56:24 | 只看该作者
汗,这个,能弄个例子吗
10#
发表于 2008-1-19 17:13:05 | 只看该作者
导出IMAGE控件图片的需另加loadpicture
SaveJPG LoadPicture(Me.Image0.Picture), "C:\DD.bmp"
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-1 07:27 , Processed in 0.098601 second(s), 33 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表