API.bas 7.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262
  1. Attribute VB_Name = "API"
  2. '// This is free and unencumbered software released into the public domain.
  3. '// For more information, please refer to https://github.com/hongwenjun
  4. '// Attribute VB_Name = "CorelVBA工具窗口启动" CorelVBA Tool Window Launches 2023.6.11
  5. '// CorelDRAW 窗口刷新优化和关闭
  6. Public Function BeginOpt(Optional ByVal name As String = "Undo")
  7. EventsEnabled = False
  8. ActiveDocument.BeginCommandGroup name
  9. ' ActiveDocument.SaveSettings
  10. ActiveDocument.Unit = cdrMillimeter
  11. Optimization = True
  12. ' ActiveDocument.PreserveSelection = False
  13. End Function
  14. Public Function EndOpt()
  15. ' ActiveDocument.PreserveSelection = True
  16. ' ActiveDocument.RestoreSettings
  17. EventsEnabled = True
  18. Optimization = False
  19. EventsEnabled = True
  20. ActiveDocument.ReferencePoint = cdrBottomLeft
  21. Application.Refresh
  22. ActiveDocument.EndCommandGroup
  23. End Function
  24. Public Function Speak_Msg(message As String)
  25. Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0")) '// 关停语音功能
  26. If Val(Speak_Help) = 1 Then
  27. Dim sapi
  28. Set sapi = CreateObject("sapi.spvoice")
  29. sapi.Speak message
  30. Else
  31. ' 不说话
  32. End If
  33. End Function
  34. Public Function GetSet(s As String)
  35. Bleed = Val(GetSetting("LYVBA", "Settings", "Bleed", "2.0"))
  36. Line_len = Val(GetSetting("LYVBA", "Settings", "Line_len", "3.0"))
  37. Outline_Width = Val(GetSetting("LYVBA", "Settings", "Outline_Width", "0.2"))
  38. ' Debug.Print Bleed, Line_len, Outline_Width
  39. If s = "Bleed" Then
  40. GetSet = Bleed
  41. ElseIf s = "Line_len" Then
  42. GetSet = Line_len
  43. ElseIf s = "Outline_Width" Then
  44. GetSet = Outline_Width
  45. End If
  46. End Function
  47. Public Function Create_Tolerance() As Double
  48. Dim text As String
  49. If GlobalUserData.Exists("Tolerance", 1) Then
  50. text = GlobalUserData("Tolerance", 1)
  51. End If
  52. text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
  53. If text = "" Then Exit Function
  54. GlobalUserData("Tolerance", 1) = text
  55. Create_Tolerance = Val(text)
  56. End Function
  57. Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
  58. Dim text As String
  59. If GlobalUserData.Exists("SpaceWidth", 1) Then
  60. text = GlobalUserData("SpaceWidth", 1)
  61. If OnlyRead Then
  62. Set_Space_Width = Val(text)
  63. Exit Function
  64. End If
  65. End If
  66. text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
  67. If text = "" Then Exit Function
  68. GlobalUserData("SpaceWidth", 1) = text
  69. Set_Space_Width = Val(text)
  70. End Function
  71. '// 获得剪贴板文本字符
  72. Public Function GetClipBoardString() As String
  73. On Error Resume Next
  74. Dim MyData As New DataObject
  75. GetClipBoardString = ""
  76. MyData.GetFromClipboard
  77. GetClipBoardString = MyData.GetText
  78. Set MyData = Nothing
  79. End Function
  80. '// 文本字符复制到剪贴板
  81. Public Function WriteClipBoard(ByVal s As String)
  82. On Error Resume Next
  83. ' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
  84. #If VBA7 Then
  85. With CreateObject("Forms.TextBox.1")
  86. .MultiLine = True
  87. .text = s
  88. .SelStart = 0
  89. .SelLength = .TextLength
  90. .Copy
  91. End With
  92. #Else
  93. Dim MyData As New DataObject
  94. MyData.SetText s
  95. MyData.PutInClipboard
  96. #End If
  97. End Function
  98. '// 换行转空格 多个空格换成一个空格
  99. Public Function Newline_to_Space(ByVal str As String) As String
  100. str = VBA.Replace(str, Chr(13), " ")
  101. str = VBA.Replace(str, Chr(9), " ")
  102. Do While InStr(str, " ")
  103. str = VBA.Replace(str, " ", " ")
  104. Loop
  105. Newline_to_Space = str
  106. End Function
  107. '// 获得数组元素个数
  108. Public Function arrlen(src As Variant) As Integer
  109. On Error Resume Next '空意味着 0 长度
  110. arrlen = (UBound(src) - LBound(src))
  111. End Function
  112. '// 对数组进行排序[单维]
  113. Public Function ArraySort(src As Variant) As Variant
  114. Dim out As Long, i As Long, tmp As Variant
  115. For out = LBound(src) To UBound(src) - 1
  116. For i = out + 1 To UBound(src)
  117. If src(out) > src(i) Then
  118. tmp = src(i): src(i) = src(out): src(out) = tmp
  119. End If
  120. Next i
  121. Next out
  122. ArraySort = src
  123. End Function
  124. '// 把一个数组倒序
  125. Public Function ArrayReverse(arr)
  126. Dim i As Integer, n As Integer
  127. n = UBound(arr)
  128. Dim P(): ReDim P(n)
  129. For i = 0 To n
  130. P(i) = arr(n - i)
  131. Next
  132. ArrayReverse = P
  133. End Function
  134. '// 测试数组排序
  135. Private Function test_ArraySort()
  136. Dim arr As Variant, i As Integer
  137. arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
  138. For i = 0 To arrlen(arr) - 1
  139. Debug.Print arr(i);
  140. Next i
  141. Debug.Print arrlen(arr)
  142. ArraySort arr
  143. For i = 0 To arrlen(arr) - 1
  144. Debug.Print arr(i);
  145. Next i
  146. End Function
  147. '// 两点连线的角度:返回角度(相对于X轴的角度)
  148. '// p为末点,O为始点
  149. Public Function alfaPP(P, o)
  150. Dim pi As Double: pi = 4 * Atn(1)
  151. Dim beta As Double
  152. If P(0) = o(0) And P(1) = o(1) Then '二点重合
  153. alfaPP = 0
  154. Exit Function
  155. ElseIf P(0) = o(0) And P(1) > o(1) Then
  156. beta = pi / 2
  157. ElseIf P(0) = o(0) And P(1) < o(1) Then
  158. beta = -pi / 2
  159. ElseIf P(1) = o(1) And P(0) < o(0) Then
  160. beta = pi
  161. ElseIf P(1) = o(1) And P(0) > o(0) Then
  162. beta = 0
  163. Else
  164. beta = Atn((P(1) - o(1)) / VBA.Abs(P(0) - o(0)))
  165. If P(1) > o(1) And P(0) < o(0) Then
  166. beta = pi - beta
  167. ElseIf P(1) < o(1) And P(0) < o(0) Then
  168. beta = -(pi + beta)
  169. End If
  170. End If
  171. alfaPP = beta * 180 / pi
  172. End Function
  173. '// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
  174. Public Function pFootInXY(P, a, b)
  175. If a(0) = b(0) Then
  176. pFootInXY = Array(a(0), P(1), 0#): Exit Function
  177. End If
  178. If a(1) = b(1) Then
  179. pFootInXY = Array(P(0), a(1), 0#): Exit Function
  180. End If
  181. Dim aa, bb, c, d, x, Y
  182. aa = (a(1) - b(1)) / (a(0) - b(0))
  183. bb = a(1) - aa * a(0)
  184. c = -(a(0) - b(0)) / (a(1) - b(1))
  185. d = P(1) - c * P(0)
  186. x = (d - bb) / (aa - c)
  187. Y = aa * x + bb
  188. pFootInXY = Array(x, Y, 0#)
  189. End Function
  190. Public Function FindAllShapes() As ShapeRange
  191. Dim s As Shape
  192. Dim srPowerClipped As New ShapeRange
  193. Dim sr As ShapeRange, srAll As New ShapeRange
  194. If ActiveSelection.Shapes.Count > 0 Then
  195. Set sr = ActiveSelection.Shapes.FindShapes()
  196. Else
  197. Set sr = ActivePage.Shapes.FindShapes()
  198. End If
  199. Do
  200. For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
  201. srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
  202. Next s
  203. srAll.AddRange sr
  204. sr.RemoveAll
  205. sr.AddRange srPowerClipped
  206. srPowerClipped.RemoveAll
  207. Loop Until sr.Count = 0
  208. Set FindAllShapes = srAll
  209. End Function
  210. ' ************* 函数模块 ************* '
  211. Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
  212. Dim fso
  213. Set fso = CreateObject("Scripting.FileSystemObject")
  214. ExistsFile_UseFso = fso.FileExists(strPath)
  215. Set fso = Nothing
  216. End Function
  217. Public Function test_sapi()
  218. Dim message, sapi
  219. MsgBox ("Please use the headset and listen to what I have to say...")
  220. message = "This is a simple voice test on your Microsoft Windows."
  221. Set sapi = CreateObject("sapi.spvoice")
  222. sapi.Speak message
  223. End Function
  224. ' Public Function WebHelp(url As String)
  225. ' Dim h As Longer, r As Long
  226. ' h = FindWindow(vbNullString, "Toolbar")
  227. ' r = ShellExecute(h, "", url, "", "", 1)
  228. ' End Function