savePDFtoClip.bas 2.8 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697
  1. Attribute VB_Name = "savePDFtoClip"
  2. #If VBA7 Then
  3. Private Declare PtrSafe Function vbadll Lib "lycpg64.cpg" (ByVal code As Long, ByVal x As Double) As Long
  4. #Else
  5. Private Declare Function vbadll Lib "lycpg32.cpg" (ByVal code As Long, ByVal x As Double) As Long
  6. #End If
  7. Sub CorelDRAW_CopyPDF()
  8. '// savePDFtoClip.CdrCopyToAI
  9. '// VBA调用CPG_CDR复制物件到AI()
  10. ret = vbadll(2, 0)
  11. End Sub
  12. Sub CorelDRAW_PastePDF()
  13. '// savePDFtoClip.AICopyToCdr
  14. '// AI复制物件到CDR()
  15. ret = vbadll(1, 0)
  16. End Sub
  17. Private Function GetTempFile(ByVal sExtension As String) As String
  18. GetTempFile = CorelScriptTools.GetTempFolder() & "CDR2AI" & "." & sExtension
  19. End Function
  20. Public Function CdrCopyToAI()
  21. On Error GoTo ErrorHandler
  22. sTempFilePDF = GetTempFile("pdf")
  23. With ActiveDocument.PDFSettings
  24. .PublishRange = 2 ' CdrPDFVBA.pdfSelection
  25. .BitmapCompression = 1 ' CdrPDFVBA.pdfLZW
  26. .JPEGQualityFactor = 2
  27. .EmbedFonts = True
  28. .EmbedBaseFonts = True
  29. .TrueTypeToType1 = True
  30. .SubsetFonts = False
  31. .SubsetPct = 80
  32. .CompressText = True
  33. .Encoding = 1 ' CdrPDFVBA.pdfBinary
  34. .ColorResolution = 300
  35. .MonoResolution = 1200
  36. .GrayResolution = 300
  37. .Hyperlinks = True
  38. .Bookmarks = True
  39. .Thumbnails = True
  40. .Startup = 0 ' CdrPDFVBA.pdfPageOnly
  41. .Overprints = True
  42. .Halftones = True
  43. .FountainSteps = 256
  44. .EPSAs = 0 ' CdrPDFVBA.pdfPostscript
  45. .pdfVersion = 6 ' CdrPDFVBA.pdfVersion15
  46. .ColorMode = 3 ' CdrPDFVBA.pdfNative
  47. .ColorProfile = 1 ' CdrPDFVBA.pdfSeparationProfile
  48. .JP2QualityFactor = 2
  49. .TextExportMode = 0 ' CdrPDFVBA.pdfTextAsUnicode
  50. .PrintPermissions = 0 ' CdrPDFVBA.pdfPrintPermissionNone
  51. .EditPermissions = 0 ' CdrPDFVBA.pdfEditPermissionNone
  52. .EncryptType = 1 ' CdrPDFVBA.pdfEncryptTypeStandard
  53. End With
  54. ActiveDocument.PublishToPDF sTempFilePDF
  55. '// 调用 pdf2clip.exe 把PDF文件加载到剪贴板, 命令行按实际文件夹填写路径
  56. cmd_line = "C:\TSP\pdf2clip.exe " & sTempFilePDF
  57. ret = Shell(cmd_line, vbHide)
  58. ErrorHandler:
  59. End Function
  60. Public Function AICopyToCdr()
  61. On Error GoTo ErrorHandler
  62. sTempFilePDF = GetTempFile("pdf")
  63. '// 调用 clip2pdf.exe 把读取剪贴板保存成PDF
  64. cmd_line = "C:\TSP\clip2pdf.exe " & sTempFilePDF
  65. Dim ret As Long
  66. ret = Shell(cmd_line, vbHide)
  67. '// 暂停 1 秒 让Shell 调用exe程序完成结果
  68. Dim startTime As Variant
  69. startTime = Now
  70. Do While (Now - startTime) < TimeSerial(0, 0, 1)
  71. DoEvents
  72. Loop
  73. Dim impopt As StructImportOptions
  74. Set impopt = CreateStructImportOptions
  75. impopt.MaintainLayers = True
  76. Dim impflt As ImportFilter
  77. Set impflt = ActiveLayer.ImportEx(sTempFilePDF, cdrAI9, impopt)
  78. impflt.Finish
  79. ErrorHandler:
  80. End Function