[coreldraw_宏]提供路径并自动导入路径中的图片做成每个页面(vba宏)


Sub main()    
    '==================================================================
    '文件名：提供路径并自动导入图片做成每个页面_宏
    '--------------------------------------------------------------
    '   功能说明：
    '       使用者提供图片的文件夹路径填入路径输入框，程序会按此路径遍历所有文件，
    '       并自动把文件插入cordraw文件的页面中(自动居中并转成cmyk)
    '--------------------------------------------------------------
    '编程实现：liwenhui   日期：2022-07-02
    '===================================================================

    '获取当前文件夹所有文件
    Dim sPath As String

    '每次运行时路径输入框：
    sPath = InputBox("请输入一个包含导入图片的文件夹的路径" & Chr(10) & "须绝对路径:(例: E:\vbCode)", "输入路径")

    '路径输入框情况判断
    If StrPtr(sPath) <> 0 Then
        If Len(Trim(sPath)) > 0 Then
            GoTo StartMacro
        Else
            MsgBox "[宏退出提示]:" & Chr(10) & "    你没有输入任何内容!"
            Exit Sub
        end If
    Else
        MsgBox "[宏退出提示]:" & Chr(10) & "    你取消并放弃输入!"
        Exit Sub
    end If

StartMacro:
    If PathExists(sPath) Then
        Folder = sPath & "\*.*"
        FileName = Dir(Folder)
        While FileName <> ""
            '调用过程----自动导入上面路径中所有图片到coreldraw每个页面中
            Call autoPicToPage(sPath & "\" & FileName)
            FileName = Dir
        Wend
        MsgBox "文件自动导入成功。", vbYes, "成功提示"
    Else
        MsgBox "指定的文件夹不存在！宏已结束运行"
    End If
End Sub

Sub autoPicToPage(sPath As String)
    '导入图片
    ActiveLayer.Import sPath
    
    ' 设置当前图片成A4大小
    ActiveDocument.ReferencePoint = cdrCenter
    ActivePage.Shapes.All.CreateSelection
    ActiveSelection.SetSize 8.267717, 11.692913
    
    ' 页面居中
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    OrigSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
    
    '这段代码用来遍历当前页面所有的位图
    '判断其颜色模式，如果不是CMYK颜色模式的图像，则将其转换为CMYK模式的图像。
    ' 声明形状变量
    Dim s As Shape
    ' 遍历当前页面所有的位图（如果要扩大或者缩小搜索范围，请替换掉ActivePage）
    For Each s In ActivePage.Shapes.FindShapes(, cdrBitmapShape)
        ' 如果当前位图不是CMYK颜色模式
        If s.Bitmap.Mode <> cdrCMYKColorImage Then
        ' 将其转换为CMYK颜色模式
        s.Bitmap.ConvertTo cdrCMYKColorImage
        End If
    Next s
    
    ' 添加一个页面
    Dim p1 As Page
    Set p1 = ActiveDocument.InsertPagesEx(1, False, ActivePage.Index, 8.267717, 11.692913)
End Sub

Public Function PathExists(strFull) As Boolean
    '// add declarations
    On Error GoTo EarlyExit
    If Not Dir(strFull, vbDirectory) = vbNullString Then PathExists = True
EarlyExit:
    '// add error handling
    On Error GoTo 0
End Function