VBA 文件夹和子文件处理

rendiule01

VBA 证件原始图片文件夹内有许多子文件夹，子文件名称是身份证号码，里面有正面和反面照片，2张或2张以上的



现在需要合并子文件夹内的图片合成一张正面在上，反面在下图片，合成的图片名称为该子文件夹的名称，


全部合成后，把原始的图片删除掉，最后把原始文件夹 全部移动到 证件合成图片上传文件内





附件.zip (1.41 MB, 下载次数: 6)

2023-3-30 15:41 上传

点击文件名下载附件

opiona

Excel内设置2个单元格 插入图片 截图保存

wanghan519

写的不好，但意思是一样的，用shell脚本新建文件夹，用imagemagick垂直连接两张图片，报错是因为有个文件夹里没有正面反面

1. ls | xargs -i ash -c 'cd {};mkdir -p ../../证件合成 图片上传/{};convert -append 正面.jpg 反面.jpg ../../证件合成图片上传/{}/{}.jpg;cd ..;'

复制代码

rendiule01

wanghan519 发表于 2023-3-30 19:24
写的不好，但意思是一样的，用shell脚本新建文件夹，用imagemagick垂直连接两张图片，报错是因为有个文件夹 ...

很强大， shell脚本，大佬没考虑 子文件内正面和反面的图片的格式 有png,jpg等格式
原始图片的子文件夹内的图片很乱的，但有代表性

liulang0808

Dim fh
Sub Sheet1_按钮1_Click()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    fh = ThisWorkbook.Path & "\证件合成图片\"
    Sheets("程序").Select
    Call Getfd(ThisWorkbook.Path & "\证件原始图片\", fso, d)
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth, fso, d)
    Set ff = fso.getfolder(pth)
    d.RemoveAll
    Call del_pic
    For Each f In ff.Files
        If InStr(f.Name, "正面") Then
            d("正面") = f
        Else
            If InStr(f.Name, "反面") Then
                d("反面") = f
            End If
        End If
    Next f
    If d.Count = 2 Then
        Call insert_pic(d("正面"), [b2])
        Call insert_pic(d("反面"), [b3])
        [d3].Select
        y = fh & ff.Name & "\"
        MkDir y
        Call create_pic(y & ff.Name & ".jpg")
    End If
    For Each fd In ff.subfolders
        Call Getfd(fd, fso, d)
    Next fd
End Sub
Sub del_pic()
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next shp
End Sub
Sub insert_pic(f, rng)
    ActiveSheet.Pictures.Insert(f).Select
    With Selection
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = rng.Left
        .Top = rng.Top
        .Width = rng.Width
        .Height = rng.Height
    End With
End Sub
Sub create_pic(fnm)
    [b2:b3].CopyPicture 1, 2
    ActiveSheet.Pictures.Paste.Select
    With Selection
        .Copy
        With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
            .Parent.Select
            .Paste
            .Export fnm
            .Parent.Delete
        End With
        .Delete
    End With
End Sub

liulang0808

B2,B3单元格大小可以根据需求重新设置
此方法是导入图片，再截图导出。 有的时候可能输出空白图片