API.bas 7.1 KB

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