求教批量裁剪图片。。。。

恶魔在人间

1、所有原图片大小都一致；

2、对裁剪后的图片，在图片上方指定位置填写不同文字；

3、裁剪后图片要按原名称指定位置重新存放。

lss001

参考一下附件代码

zhumin1025

lss001 发表于 2024-9-24 09:01
参考一下附件代码

楼主好像传错附件了，没有代码呢！

lss001

zhumin1025 发表于 2024-9-26 13:18
楼主好像传错附件了，没有代码呢！

谢谢提醒，附件已经取消了！

perfect131

可以搞 如果有偿找我 纯vba

恶魔在人间

lss001 发表于 2024-9-26 13:49
谢谢提醒，附件已经取消了！

大佬，求代码

lizhipei78

perfect131 发表于 2024-9-26 14:28
可以搞 如果有偿找我 纯vba

图片添加文字，可以给一个代码案例么？我只知道加图片水印的代码

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar(), br, i&, j&, r&, pic As Picture, dWidth#, dHeight#
    Dim strFileName As String, strPath As String, strSavePath$

    strPath = ThisWorkbook.Path & "\1原图片\"
    strSavePath = ThisWorkbook.Path & "\2新图片\"
    strFileName = Dir(strPath & "*.jpeg")
    Do Until strFileName = ""
        r = r + 1
        ReDim Preserve ar(1 To 2, 1 To r)
        ar(1, r) = strPath & strFileName
        ar(2, r) = strSavePath & strFileName
        strFileName = Dir
    Loop
   
    If r = 0 Then MsgBox "没有图片，请检查！": Exit Sub
    If Dir(strSavePath, vbDirectory) = "" Then MkDir strSavePath
   
    For j = 1 To UBound(ar, 2)
        br = GetPic(ar(1, j))
        Set pic = ActiveSheet.Pictures.Insert(ar(1, j))
        With pic
            .ShapeRange.LockAspectRatio = msoTrue
            .Width = br(1) * 0.75
            .ShapeRange.PictureFormat.CropTop = 100
            dWidth = .Width
            dHeight = .Height
            .Cut
        End With
        With ActiveSheet.ChartObjects.Add(0, 0, dWidth, dHeight).Chart
              .Parent.Select
              .Paste
              With .Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 200, 35)
                  With .TextFrame2.TextRange
                      .Font.Size = 18
                      .Characters.Text = "自己需要加入的文字"
                  End With
                  .Select
                  With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
                      .Visible = msoTrue
                      .ForeColor.RGB = vbYellow
                      .Transparency = 0
                      .Solid
                  End With
             End With
             .Export ar(2, j)
            .Parent.Delete
        End With
    Next j
    Beep
End Sub
Function GetPic(ByVal strFileName$) As Long()
    Dim ar&(1)
    With CreateObject("WIA.ImageFile")
        .LoadFile strFileName
        ar(0) = .Height: ar(1) = .Width
    End With
    GetPic = ar
End Function

gwjkkkkk

请参考附件。。。

A刘志勇

学习了图片更改