1
1

frmEditPowerClip.frm 8.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241
  1. Option Explicit
  2. Dim xzbj As Boolean
  3. Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  4. Call commdanliu(Lab001)
  5. Call commdanliu(Lab002)
  6. Call commdanliu(Lab003)
  7. Call commdanliu(Lab004)
  8. Call commdanliu(Lab005)
  9. Call commdanliu(Lab006)
  10. Call commdanliu(Lab007)
  11. Call commdanliu(Lab008)
  12. End Sub
  13. Private Sub Lab001_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  14. Call anliumove(Lab001)
  15. End Sub
  16. Private Sub Lab002_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  17. Call anliumove(Lab002)
  18. End Sub
  19. Private Sub Lab003_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  20. Call anliumove(Lab003)
  21. End Sub
  22. Private Sub Lab004_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  23. Call anliumove(Lab004)
  24. End Sub
  25. Private Sub Lab005_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  26. Call anliumove(Lab005)
  27. End Sub
  28. Private Sub Lab006_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  29. Call anliumove(Lab006)
  30. End Sub
  31. Private Sub Lab007_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  32. Call anliumove(Lab007)
  33. End Sub
  34. Private Sub Lab008_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  35. Call anliumove(Lab008)
  36. End Sub
  37. Private Sub Lab001_Click()
  38. BeginOpt "提取裁切框内容"
  39. Container.Extractall (IIf(CheckBox1.Value, True, False))
  40. EndOpt
  41. End Sub
  42. Private Sub Lab002_Click()
  43. BeginOpt "清空裁切框"
  44. Container.Emptyall
  45. EndOpt
  46. End Sub
  47. Private Sub Lab003_Click()
  48. BeginOpt "按比例调整内容"
  49. Container.Bilingtznr
  50. EndOpt
  51. End Sub
  52. Private Sub Lab004_Click()
  53. BeginOpt "按比例填充"
  54. Container.Bilintianchun
  55. EndOpt
  56. End Sub
  57. Private Sub Lab005_Click()
  58. BeginOpt "延展填充"
  59. Container.Qiangzhitianmian
  60. EndOpt
  61. End Sub
  62. Private Sub Lab006_Click()
  63. BeginOpt "锁定精确裁剪"
  64. Container.Lockall True
  65. EndOpt
  66. End Sub
  67. Private Sub Lab007_Click()
  68. BeginOpt "解锁精确裁剪"
  69. Container.Lockall False
  70. EndOpt
  71. End Sub
  72. Private Sub Lab008_Click()
  73. BeginOpt "内容居中"
  74. Container.CenterToPC
  75. EndOpt
  76. End Sub
  77. Private Sub txtNilai_Change()
  78. Dim i As Integer
  79. Dim s As String
  80. With txtNilai
  81. For i = 1 To VBA.Len(.text)
  82. s = VBA.Mid(.text, i, 1)
  83. Select Case s
  84. Case ".", "0" To "9"
  85. Case Else
  86. .text = VBA.Replace(.text, s, "")
  87. End Select
  88. Next
  89. End With
  90. End Sub
  91. Private Sub SpinButton1_SpinUp()
  92. txtNilai.text = VBA.CStr(txtNilai.Value + 1)
  93. End Sub
  94. Private Sub SpinButton1_SpinDown()
  95. If txtNilai.Value <= 1 Then Exit Sub
  96. txtNilai.text = VBA.CStr(txtNilai.Value - 1)
  97. End Sub
  98. Private Sub UserForm_Initialize()
  99. If Strbjini = "" Then Strbjini = VBA.GetSetting(xylAppName, xylSection, "Apppath"): BJAppLJ = Strbjini & "\DaTa\dat\"
  100. If GetmdbValue(BJAppLJ & "xylTools.ini", "Form", "rqtzFr_l", "") <> "" Then
  101. Me.StartUpPosition = 0
  102. Me.Left = GetmdbValue(BJAppLJ & "xylTools.ini", "Form", "rqtzFr_l", "")
  103. Me.Top = GetmdbValue(BJAppLJ & "xylTools.ini", "Form", "rqtzFr_t", "")
  104. End If
  105. Call AddStroyComandBox(Me.cboUnit, "毫米,厘米,英寸,像素")
  106. Me.cboUnit.text = GetmdbValue(BJAppLJ & "xylTools.ini", "Rongqibjtz", "单位", "毫米")
  107. xzbj = False
  108. cboUnit.Enabled = False
  109. txtNilai.Enabled = False
  110. SpinButton1.Enabled = False
  111. spnPositionX.Enabled = False
  112. spnPositionY.Enabled = False
  113. spnZoom.Enabled = False
  114. spnRotate.Enabled = False
  115. Me.Tis.BackColor = RGB(0, 147, 222)
  116. Me.Tis.ForeColor = RGB(255, 255, 255)
  117. Me.Tis.Caption = " 可以选择一个容器对象后操作!"
  118. End Sub
  119. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  120. SetmdbValue BJAppLJ & "xylTools.ini", "Form", "rqtzFr_l", frmEditPowerClip.Left
  121. SetmdbValue BJAppLJ & "xylTools.ini", "Form", "rqtzFr_t", frmEditPowerClip.Top
  122. SetmdbValue BJAppLJ & "xylTools.ini", "Rongqibjtz", "单位", Me.cboUnit.text
  123. End Sub
  124. Sub getShapeByUser()
  125. re:
  126. Dim doc As Document, retval As Long
  127. Dim x As Double, Y As Double, Shift As Long
  128. Dim o_seleksi As ShapeRange
  129. Set doc = ActiveDocument
  130. doc.ReferencePoint = cdrCenter
  131. retval = doc.GetUserClick(x, Y, Shift, 10, True, cdrCursorPick)
  132. doc.ActivePage.SelectShapesAtPoint x, Y, True
  133. Dim SC As Shape
  134. Dim sp As PowerClip
  135. Set SC = ActiveShape
  136. If SC Is Nothing Then xzbj = False: Me.Show: Exit Sub
  137. Set sp = SC.PowerClip
  138. If sp Is Nothing Then
  139. AutoMsgbox "选择对象不是容器;" & vbCrLf & "可以重新选择,或点击空白处退出!", vbCritical, "新印联提示": GoTo re
  140. Else
  141. If sp.Shapes.Count = 0 Then
  142. AutoMsgbox "容器为空;" & vbCrLf & "可以重新选择,或点击空白处退出!", vbCritical, "新印联提示": GoTo re
  143. End If
  144. End If
  145. xzbj = True
  146. End Sub
  147. Sub doAction(ByVal doAction As String, Optional ByVal bolUp As Boolean = False)
  148. doAction = VBA.LCase(doAction)
  149. ActiveDocument.ReferencePoint = cdrCenter
  150. If cboUnit.ListIndex = 0 Then
  151. ActiveDocument.Unit = cdrMillimeter
  152. ElseIf cboUnit.ListIndex = 1 Then
  153. ActiveDocument.Unit = cdrCentimeter
  154. ElseIf cboUnit.ListIndex = 2 Then
  155. ActiveDocument.Unit = cdrInch
  156. ElseIf cboUnit.ListIndex = 3 Then
  157. ActiveDocument.Unit = cdrPixel
  158. End If '
  159. Dim setNilai As Double
  160. setNilai = CDbl(txtNilai.Value)
  161. If bolUp = False Then setNilai = -setNilai
  162. Dim s As Shape, sr As ShapeRange
  163. Set sr = ActiveSelectionRange
  164. For Each s In sr
  165. Call checkPowerClip(s, doAction, setNilai, bolUp)
  166. Next s
  167. End Sub
  168. Private Function checkPowerClip(s As Shape, ByVal doAction As String, ByVal setNilai As Double, ByVal bolUp As Boolean)
  169. Dim pwc As PowerClip, sr As ShapeRange
  170. If Not s.PowerClip Is Nothing Then
  171. Set pwc = s.PowerClip
  172. Set sr = pwc.Shapes.FindShapes
  173. If doAction = "position_x" Then
  174. sr.PositionX = sr.PositionX + setNilai
  175. ElseIf doAction = "position_y" Then
  176. sr.PositionY = sr.PositionY + setNilai
  177. ElseIf doAction = "rotate" Then
  178. sr.Rotate setNilai
  179. ElseIf doAction = "zoom" Then
  180. sr.Stretch sr.SizeWidth / (sr.SizeWidth + setNilai)
  181. End If
  182. End If
  183. End Function
  184. Private Sub cmdPickObject_Click()
  185. Me.Hide
  186. Call getShapeByUser
  187. If xzbj = True Then
  188. Me.Tis.Caption = " 可以重新选择一个容器操作!"
  189. If cmdPickObject.ControlTipText = "选择容器" Then
  190. cboUnit.Enabled = True
  191. txtNilai.Enabled = True
  192. SpinButton1.Enabled = True
  193. spnPositionX.Enabled = True
  194. spnPositionY.Enabled = True
  195. spnZoom.Enabled = True
  196. spnRotate.Enabled = True
  197. End If
  198. Me.Show
  199. cmdPickObject.ControlTipText = "重新选择一个容器"
  200. End If
  201. End Sub
  202. Private Sub spnPositionX_SpinDown()
  203. Call doAction("position_x", False)
  204. End Sub
  205. Private Sub spnPositionX_SpinUp()
  206. Call doAction("position_x", True)
  207. End Sub
  208. Private Sub spnPositionY_SpinDown()
  209. Call doAction("position_y", False)
  210. End Sub
  211. Private Sub spnPositionY_SpinUp()
  212. Call doAction("position_y", True)
  213. End Sub
  214. Private Sub spnRotate_SpinUp()
  215. Call doAction("rotate", False)
  216. End Sub
  217. Private Sub spnRotate_SpinDown()
  218. Call doAction("rotate", True)
  219. End Sub
  220. Private Sub spnZoom_SpinUp()
  221. Call doAction("zoom", False)
  222. End Sub
  223. Private Sub spnZoom_SpinDown()
  224. Call doAction("zoom", True)
  225. End Sub
  226. Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  227. cmdPickObject.SpecialEffect = fmSpecialEffectEtched
  228. End Sub
  229. Private Sub cmdPickObject_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  230. cmdPickObject.SpecialEffect = fmSpecialEffectSunken
  231. End Sub
  232. Private Sub cmdPickObject_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  233. cmdPickObject.SpecialEffect = fmSpecialEffectRaised
  234. End Sub
  235. Private Sub cmdPickObject_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  236. If Button = 0 Then
  237. cmdPickObject.SpecialEffect = fmSpecialEffectRaised
  238. ElseIf Button = 1 Then
  239. cmdPickObject.SpecialEffect = fmSpecialEffectSunken
  240. End If
  241. End Sub