1
1

PhotoForm.frm 2.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} PhotoForm
  3. Caption = "Batch Convert Img Or Export JPEG"
  4. ClientHeight = 1755
  5. ClientLeft = 45
  6. ClientTop = 375
  7. ClientWidth = 3855
  8. OleObjectBlob = "PhotoForm.frx":0000
  9. ShowModal = 0 'False
  10. StartUpPosition = 1 'CenterOwner
  11. End
  12. Attribute VB_Name = "PhotoForm"
  13. Attribute VB_GlobalNameSpace = False
  14. Attribute VB_Creatable = False
  15. Attribute VB_PredeclaredId = True
  16. Attribute VB_Exposed = False
  17. Private Sub UserForm_Initialize()
  18. On Error Resume Next
  19. ComboBox1.AddItem "灰度"
  20. ComboBox1.AddItem "CMYK颜色"
  21. ComboBox1.AddItem "RGB颜色"
  22. ComboBox1.AddItem "黑白"
  23. ComboBox2.AddItem "300", 0
  24. ComboBox2.AddItem "450", 1
  25. ComboBox2.AddItem "600", 2
  26. ComboBox2.AddItem "150", 3
  27. End Sub
  28. Private Sub CovPhotos_Click()
  29. On Error Resume Next
  30. ActiveDocument.BeginCommandGroup
  31. Dim Color As String
  32. Dim a, b As Boolean
  33. Dim i, dpi As Integer
  34. a = True: b = True
  35. If ABox1.value = False Then a = False
  36. If BBox2.value = False Then b = False
  37. dpi = CInt(ComboBox2.text)
  38. Select Case ComboBox1.text
  39. Case Is = "灰度"
  40. Color = cdrGrayscaleImage
  41. Case Is = "CMYK颜色"
  42. Color = cdrCMYKColorImage
  43. Case Is = "RGB颜色"
  44. Color = cdrRGBColorImage
  45. Case Is = "黑白"
  46. Color = cdrBlackAndWhiteImage
  47. End Select
  48. Dim s As Shapes
  49. Set s = ActiveSelection.Shapes
  50. If s Is Nothing Then
  51. MsgBox "请先选中一个形状!"
  52. Exit Sub
  53. Else
  54. For i = 1 To s.Count
  55. Set s(i) = ActiveShape.ConvertToBitmapEx(Color, False, a, dpi, cdrNormalAntiAliasing, True, False, 95)
  56. Next i
  57. End If
  58. ActiveDocument.EndCommandGroup
  59. End Sub
  60. Private Sub Export_JPEG_Click()
  61. On Error Resume Next
  62. Dim d As Document
  63. Set d = ActiveDocument
  64. Dim sh As Shape, shs As Shapes
  65. Dim Color As String
  66. Set shs = ActiveSelection.Shapes
  67. dpi = CInt(ComboBox2.text)
  68. Select Case ComboBox1.text
  69. Case Is = "灰度"
  70. Color = cdrGrayscaleImage
  71. Case Is = "CMYK颜色"
  72. Color = cdrCMYKColorImage
  73. Case Is = "RGB颜色"
  74. Color = cdrRGBColorImage
  75. Case Is = "黑白"
  76. Color = cdrBlackAndWhiteImage
  77. End Select
  78. '// 导出图片精度设置,设置颜色模式
  79. Dim opt As New StructExportOptions
  80. opt.ResolutionX = dpi
  81. opt.ResolutionY = dpi
  82. opt.ImageType = Color
  83. Dim path$: path = CorelScriptTools.GetFolder
  84. '// 批处理导出图片
  85. For Each sh In shs
  86. ActiveDocument.ClearSelection
  87. sh.CreateSelection
  88. ' 导出图片 JPEG格式
  89. f = path & "\" & d.FileName & "_ID" & sh.StaticID & ".jpg"
  90. d.Export f, cdrJPEG, cdrSelection, opt
  91. Next sh
  92. End Sub