基于cdr的一种批量导入图片生成批量cdr文件的方法

Sub PLinsert()
    cdrpath = InputBox("请输入cdr文件路径:", "FilePath", "示例：D:\cdr") & "\"
    cdrFile = Dir(cdrpath & "*.jpg")
    Do While cdrFile <> ""
    Dim createopt As StructCreateOptions
    Set createopt = CreateStructCreateOptions
    With createopt
        .Name = "未命名 -1"
        .Units = cdrMillimeter
        .PageWidth = 297#
        .PageHeight = 210#
        .Resolution = 600#
        .ColorContext = CreateColorContext2("sRGB IEC61966-2.1,Japan Color 2001 Coated,Dot Gain 15%", BlendingColorModel:=clrColorModelCMYK)
    End With
    Dim doc1 As Document
    Set doc1 = CreateDocumentEx(createopt)
    ActiveDocument.Unit = cdrMillimeter
    ActivePage.SetSize 70, 45
    Dim impopt As StructImportOptions
    Set impopt = CreateStructImportOptions
    With impopt
        .Mode = cdrImportFull
        .MaintainLayers = True
        With .ColorConversionOptions
            .SourceColorProfileList = "sRGB IEC61966-2.1,Japan Color 2001 Coated,Dot Gain 15%"
            .TargetColorProfileList = "sRGB IEC61966-2.1,Japan Color 2001 Coated,Dot Gain 15%"
        End With
    End With
    Dim s1 As Shape
    Set s1 = ActiveLayer.CreateRectangle(0#, 45, 70, 0#)
    s1.Rectangle.CornerType = cdrCornerTypeRound
    s1.Rectangle.RelativeCornerScaling = True
    s1.Fill.ApplyNoFill
    s1.Outline.SetPropertiesEx 0.007874, OutlineStyles(0), CreateCMYKColor(0, 0, 0, 100), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#, Justification:=cdrOutlineJustificationMiddle
    With ActivePage
        .SetSize 70, 45
        .Orientation = 1
        .PrintExportBackground = True
        .Bleed = 0.15748
        .Background = 0
    End With
    s1.Style.StringAssign "{""fill"":{""primaryColor"":""CMYK,USER,0,0,0,100,100,00000000-0000-0000-0000-000000000000"",""secondaryColor"":""CMYK,USER,0,0,0,0,100,00000000-0000-0000-0000-000000000000""},""outline"":{""width"":""3528"",""color"":""CMYK,USER,0,0,0,100,100,00000000-0000-0000-0000-000000000000""},""transparency"":{}}"
    Dim impflt As ImportFilter
    Set impflt = ActiveLayer.ImportEx(cdrpath & cdrFile, cdrJPEG, impopt)
    impflt.Finish
    ActiveLayer.Shapes(1).AddToPowerClip s1
    Dim SaveOptions As StructSaveAsOptions
    Set SaveOptions = CreateStructSaveAsOptions
    With SaveOptions
        .EmbedVBAProject = False
        .Filter = cdrCDR
        .IncludeCMXData = False
        .Range = cdrAllPages
        .EmbedICCProfile = False
        .Version = cdrVersion21
        .KeepAppearance = True
    End With
    doc1.SaveAs cdrpath & cdrFile & ".cdr", SaveOptions
    doc1.Close
    cdrFile = Dir
    Loop
End Sub