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
基于cdr的一种批量导入图片生成批量cdr文件的方法
最新推荐文章于 2024-12-31 13:13:28 发布