您现在的位置是:首页 > IT资讯 > 软件教程 >

word右键怎么增加图片另存为选项教程 Word怎么保存图片

作者:佚名 更新时间:2018-08-16 18:15:00 来源:卡饭 评论

关键字:  word右键怎么增加图片另存为选项教程 Word怎么保存图片    

如果我们想把word中的图片保存下来,苦恼word无法使用右键图片另存为,接下来小编就为大家介绍一下如何使用VBA代码增加图片另存为

代码如下:

Option Explicit

Private Const UnitPixel                  As Long = 2

Private Const EncoderQuality             As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Private Type GdiplusStartupInput

    GdiplusVersion           As Long

    DebugEventCallback       As Long

    SuppressBackgroundThread As Long

    SuppressExternalCodecs   As Long

End Type

Private Enum EncoderParameterValueType

    EncoderParameterValueTypeByte = 1

    EncoderParameterValueTypeASCII = 2

    EncoderParameterValueTypeShort = 3

    EncoderParameterValueTypeLong = 4

    EncoderParameterValueTypeRational = 5

    EncoderParameterValueTypeLongRange = 6

    EncoderParameterValueTypeUndefined = 7

    EncoderParameterValueTypeRationalRange = 8

End Enum

Private Type EncoderParameter

    GUID(0 To 3)        As Long

    NumberOfValues      As Long

    Type                As EncoderParameterValueType

    Value               As Long

End Type

Private Type EncoderParameters

    Count               As Long

    Parameter           As EncoderParameter

End Type

Private Type ImageCodecInfo

    ClassID(0 To 3)     As Long

    FormatID(0 To 3)    As Long

    CodecName           As Long

    DllName             As Long

    FormatDescription   As Long

    FilenameExtension   As Long

    MimeType            As Long

    Flags               As Long

    Version             As Long

    SigCount            As Long

    SigSize             As Long

    SigPattern          As Long

    SigMask             As Long

End Type

Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long

Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)

Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long

Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image 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 GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long

Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long

Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal Bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long

Public Enum ImageFileFormat

    Bmp = 1

    Jpg = 2

    Png = 3

    Gif = 4

End Enum

Public Function SaveStdPicToFile(Stdpic As StdPicture, ByVal FileName As String, _

                              Optional ByVal FileFormat As ImageFileFormat = Jpg, _

                              Optional ByVal JpgQuality As Long = 80, _

                              Optional Resolution As Single) As Boolean

Dim CLSID(3)        As Long

    Dim Bitmap          As Long

    Dim Token           As Long

    Dim Gsp             As GdiplusStartupInput

Gsp.GdiplusVersion = 1                      'GDI+ 1.0版本

    GdiplusStartup Token, Gsp                   '初始化GDI+

    GdipCreateBitmapFromHBITMAP Stdpic.Handle, Stdpic.hPal, Bitmap

    If Bitmap <> 0 Then                          '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了

        GdipBitmapSetResolution Bitmap, Resolution, Resolution

        Select Case FileFormat

        Case ImageFileFormat.Bmp

            If Not GetEncoderClsID("Image/bmp", CLSID) = -1 Then

                SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)

            End If

        Case ImageFileFormat.Jpg                    'JPG格式可以设置保存的质量

            Dim aEncParams()        As Byte

            Dim uEncParams          As EncoderParameters

            If GetEncoderClsID("Image/jpeg", CLSID) <> -1 Then

                uEncParams.Count = 1                                        ' 设置自定义的编码参数,这里为1个参数

                If JpgQuality < 0 Then

                    JpgQuality = 0

                ElseIf JpgQuality > 100 Then

                    JpgQuality = 100

                End If

                ReDim aEncParams(1 To Len(uEncParams))

                With uEncParams.Parameter

                    .NumberOfValues = 1

                    .Type = EncoderParameterValueTypeLong                   ' 设置参数值的数据类型为长整型

                    Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))  ' 设置参数唯一标志的GUID,这里为编码品质

                    .Value = VarPtr(JpgQuality)                                ' 设置参数的值:品质等级,最高为100,图像文件大小与品质成正比

                End With

                CopyMemory aEncParams(1), uEncParams, Len(uEncParams)

                SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0)

            End If

        Case ImageFileFormat.Png

            If Not GetEncoderClsID("Image/png", CLSID) = -1 Then

                SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)

            End If

        Case ImageFileFormat.Gif

            If Not GetEncoderClsID("Image/gif", CLSID) = -1 Then                '如果原始的图像是24位,则这个函数会调用系统的调色板来将图像转换为8位,转换的效果会不尽人意,但也有可能系统不自动转换,保存失败

                SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)

            End If

        End Select

    End If

    GdipDisposeImage Bitmap      '注意释放资源

    GdiplusShutdown Token       '关闭GDI+。

End Function

Private Function GetEncoderClsID(strMimeType As String, ClassID() As Long) As Long

    Dim Num         As Long

    Dim Size        As Long

    Dim I           As Long

    Dim Info()      As ImageCodecInfo

    Dim Buffer()    As Byte

    GetEncoderClsID = -1

    GdipGetImageEncodersSize Num, Size               '得到解码器数组的大小

    If Size <> 0 Then

       ReDim Info(1 To Num) As ImageCodecInfo       '给数组动态分配内存

       ReDim Buffer(1 To Size) As Byte

       GdipGetImageEncoders Num, Size, Buffer(1)            '得到数组和字符数据

       CopyMemory Info(1), Buffer(1), (Len(Info(1)) * Num)     '复制类头

       For I = 1 To Num             '循环检测所有解码

           If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then         '必须把指针转换成可用的字符

               CopyMemory ClassID(0), Info(I).ClassID(0), 16  '保存类的ID

               GetEncoderClsID = I      '返回成功的索引值

               Exit For

           End If

       Next

    End If

End Function

Private Function PtrToStrW(ByVal lpsz As Long) As String

    Dim Out         As String

    Dim Length      As Long

    Length = lstrlenW(lpsz)

    If Length > 0 Then

        Out = StrConv(String$(Length, vbNullChar), vbUnicode)

        CopyMemory ByVal Out, ByVal lpsz, Length * 2

        PtrToStrW = StrConv(Out, vbFromUnicode)

    End If

End Function

 

For Each cbn In Array("AutoText", "Drawing Canvas", "Organization Chart", "Diagram", "Frames", "Flowchart", "Inline Picture", "Floating Picture", "Shapes", "Inline Canvas", "Table Pictures", "AutoShapes", "Basic Shapes", "Insert Shape", "Picture", "WordArt Context Menu", "WordArt")

本文来源为卡饭,由西西下载站小编独立撰写整理创作而来,禁止一切形式转载。本网站/公司保留按照《中华人民共和国著作权法》追究违者法律责任的权利。
分享:
推荐内容
热点内容

网站服务:

西西下载专题合作 : QQ:2853389662 (请注明广告投放内容)
联系EMAIL :web@down.cc(请注明广告投放内容)

@西西下载

西西下载官方微信

Copyright (C) 2007-2015 DOWN.CC 西西下载, All Rights Reserved 版权声明 | 关于我们 | 联系我们 | 苏ICP备13052634号-3 | 网站地图(XML)