ExcelVBA裁剪图片并添加文本示例

lss001

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Type PicBmp
    Size   As Long
    Type   As Long
    hbmp   As LongPtr
    hpal   As Long
    Reserved   As Long
End Type

Private Declare PtrSafe Function OleCreatePictureIndirect _
     Lib "oleaut32.dll" (PicDesc As PicBmp, RefIID As GUID, _
     ByVal fPictureOwnsHandle As Long, IPic As Any) As Long
Private Declare PtrSafe Function CLSIDFromString _
     Lib "ole32" (ByVal Str As LongLong, id As GUID) As Long
Private Declare PtrSafe Function GetClipboardData _
     Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard _
     Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard _
     Lib "user32" () As Long

Const CF_BITMAP = 2

Sub picGropTop()
    Dim sht As Sheet1, tJ As GUID, pit As Object
    Dim pic As PicBmp, hBp As LongPtr, ft!, tp!
    Dim tName$, pName$, r$, s$, t$, p$, f$, d
    Dim IPic As StdPicture, pf As PictureFormat

    Set sht = ActiveSheet
    p = ThisWorkbook.Path & "\原图片" '指定打开文件夹
    s = ThisWorkbook.Path & "\新图片" '指定保存文件夹
    f = Dir(p & "\*.jpeg") '指定图片类型
    While f <> ""
        sht.Range("A1").Select
        Set pit = sht.Pictures.Insert(p & "\" & f)
        pName = pit.Name: pit.Select
        Set pf = Selection.ShapeRange.PictureFormat
        pf.CropTop = 100 '上部裁剪100
        r = pit.TopLeftCell.Address '地址
        ft = pit.TopLeftCell.Left + 15 '位置
        tp = pit.TopLeftCell.Top + 10
   
        sht.Range(r).Select
        t = "ABCD" '指定文字
        With sht.Shapes.AddTextEffect( _
            31, t, "宋体", 24, 0, 0, ft, tp)
            .TextFrame.Characters.Font.Color = VBA.vbRed
            .TextFrame.AutoSize = True
            tName = .Name
            .Select
        End With
        With sht.Shapes.Range(Array(pName, tName)).Group
            Application.CutCopyMode = False
            .Copy '复制图片
            OpenClipboard 0& '打开剪贴板
            hBp = GetClipboardData(CF_BITMAP) '获取数据
            CloseClipboard '关闭剪贴板
            
            If hBp Then
                CLSIDFromString StrPtr( _
                    "{00020400-0000-0000-C000-000000000046}"), tJ
                With pic               '填充结构
                      .Size = Len(pic) '结构大小
                      .Type = 1        '图形类型
                      .hbmp = hBp      '位图句柄
                      .hpal = 0        '设置Pallete
                End With
                d = Timer: While Timer < d + 1: DoEvents: Wend
                OleCreatePictureIndirect pic, tJ, 1, IPic
                SavePicture IPic, s & "\" & f  '保存
            End If
            .Delete   '删除
        End With
        f = Dir
    Wend
   
    Set pf = Nothing '释放
    Set pit = Nothing
    MsgBox "已完成！"
End Sub

lizhipei78

厉害，我用你这个代码提示出错

lss001

lizhipei78 发表于 2024-9-27 12:21
厉害，我用你这个代码提示出错

以上代码适合Office64位
32位Office请把PtrSafe全部删除
LongPtr全部替换为Long
LongLong全部替换为Long

lizhipei78

lss001 发表于 2024-9-27 12:25
以上代码适合Office64位
32位Office请把PtrSafe全部删除
LongPtr全部替换为Long

非常感谢，不知道什么原因，处理第二张图片的时候，这句代码出错
OleCreatePictureIndirect pic, tJ, 1, IPic
处理第一张图片是成功的

lss001

lizhipei78 发表于 2024-9-27 12:45
非常感谢，不知道什么原因，处理第二张图片的时候，这句代码出错
OleCreatePictureIndirect pic, tJ, 1, ...

谢谢提醒，楼上已经更新代码
主要是第一个WinApi函数声明

lizhipei78

运行成功，太厉害了，不过好像这个添加文字水印的并没有添加图片的效率高，下面这个是我写的
https://club.excelhome.net/threa ... tml?_dsign=2ce18113

lss001

lizhipei78 发表于 2024-9-27 18:36
运行成功，太厉害了，不过好像这个添加文字水印的并没有添加图片的效率高，下面这个是我写的
https://club ...

wia对象直接操作图片效率好些
shape对象需要在表格中操作效率差些