API.bas 7.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269
  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 GetLngCode() As Long
  48. GetLngCode = Val(GetSetting("LYVBA", "Settings", "I18N_LNG", "1033"))
  49. End Function
  50. Public Function Create_Tolerance() As Double
  51. Dim text As String
  52. If GlobalUserData.Exists("Tolerance", 1) Then
  53. text = GlobalUserData("Tolerance", 1)
  54. End If
  55. LNG_CODE = API.GetLngCode
  56. text = InputBox(i18n("Please enter a tolerance value 0.1 --> 9.9", LNG_CODE), i18n("Tolerance(mm)", LNG_CODE), text)
  57. If text = "" Then Exit Function
  58. GlobalUserData("Tolerance", 1) = text
  59. Create_Tolerance = Val(text)
  60. End Function
  61. Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
  62. Dim text As String
  63. If GlobalUserData.Exists("SpaceWidth", 1) Then
  64. text = GlobalUserData("SpaceWidth", 1)
  65. If OnlyRead Then
  66. Set_Space_Width = Val(text)
  67. Exit Function
  68. End If
  69. End If
  70. LNG_CODE = API.GetLngCode
  71. text = InputBox(i18n("Please enter a gap width value -99 --> 99", LNG_CODE), i18n("Set Space Width(mm)", LNG_CODE), text)
  72. If text = "" Then Exit Function
  73. GlobalUserData("SpaceWidth", 1) = text
  74. Set_Space_Width = Val(text)
  75. End Function
  76. '// 获得剪贴板文本字符
  77. Public Function GetClipBoardString() As String
  78. On Error Resume Next
  79. Dim MyData As New DataObject
  80. GetClipBoardString = ""
  81. MyData.GetFromClipboard
  82. GetClipBoardString = MyData.GetText
  83. Set MyData = Nothing
  84. End Function
  85. '// 文本字符复制到剪贴板
  86. Public Function WriteClipBoard(ByVal s As String)
  87. On Error Resume Next
  88. ' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
  89. #If VBA7 Then
  90. With CreateObject("Forms.TextBox.1")
  91. .MultiLine = True
  92. .text = s
  93. .SelStart = 0
  94. .SelLength = .TextLength
  95. .Copy
  96. End With
  97. #Else
  98. Dim MyData As New DataObject
  99. MyData.SetText s
  100. MyData.PutInClipboard
  101. #End If
  102. End Function
  103. '// 换行转空格 多个空格换成一个空格
  104. Public Function Newline_to_Space(ByVal str As String) As String
  105. str = VBA.Replace(str, Chr(13), " ")
  106. str = VBA.Replace(str, Chr(9), " ")
  107. Do While InStr(str, " ")
  108. str = VBA.Replace(str, " ", " ")
  109. Loop
  110. Newline_to_Space = str
  111. End Function
  112. '// 获得数组元素个数
  113. Public Function arrlen(src As Variant) As Integer
  114. On Error Resume Next '空意味着 0 长度
  115. arrlen = (UBound(src) - LBound(src))
  116. End Function
  117. '// 对数组进行排序[单维]
  118. Public Function ArraySort(src As Variant) As Variant
  119. Dim out As Long, i As Long, tmp As Variant
  120. For out = LBound(src) To UBound(src) - 1
  121. For i = out + 1 To UBound(src)
  122. If src(out) > src(i) Then
  123. tmp = src(i): src(i) = src(out): src(out) = tmp
  124. End If
  125. Next i
  126. Next out
  127. ArraySort = src
  128. End Function
  129. '// 把一个数组倒序
  130. Public Function ArrayReverse(arr)
  131. Dim i As Integer, n As Integer
  132. n = UBound(arr)
  133. Dim P(): ReDim P(n)
  134. For i = 0 To n
  135. P(i) = arr(n - i)
  136. Next
  137. ArrayReverse = P
  138. End Function
  139. '// 测试数组排序
  140. Private Function test_ArraySort()
  141. Dim arr As Variant, i As Integer
  142. arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
  143. For i = 0 To arrlen(arr) - 1
  144. Debug.Print arr(i);
  145. Next i
  146. Debug.Print arrlen(arr)
  147. ArraySort arr
  148. For i = 0 To arrlen(arr) - 1
  149. Debug.Print arr(i);
  150. Next i
  151. End Function
  152. '// 两点连线的角度:返回角度(相对于X轴的角度)
  153. '// p为末点,O为始点
  154. Public Function alfaPP(P, o)
  155. Dim pi As Double: pi = 4 * Atn(1)
  156. Dim beta As Double
  157. If P(0) = o(0) And P(1) = o(1) Then '二点重合
  158. alfaPP = 0
  159. Exit Function
  160. ElseIf P(0) = o(0) And P(1) > o(1) Then
  161. beta = pi / 2
  162. ElseIf P(0) = o(0) And P(1) < o(1) Then
  163. beta = -pi / 2
  164. ElseIf P(1) = o(1) And P(0) < o(0) Then
  165. beta = pi
  166. ElseIf P(1) = o(1) And P(0) > o(0) Then
  167. beta = 0
  168. Else
  169. beta = Atn((P(1) - o(1)) / VBA.Abs(P(0) - o(0)))
  170. If P(1) > o(1) And P(0) < o(0) Then
  171. beta = pi - beta
  172. ElseIf P(1) < o(1) And P(0) < o(0) Then
  173. beta = -(pi + beta)
  174. End If
  175. End If
  176. alfaPP = beta * 180 / pi
  177. End Function
  178. '// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
  179. Public Function pFootInXY(P, a, b)
  180. If a(0) = b(0) Then
  181. pFootInXY = Array(a(0), P(1), 0#): Exit Function
  182. End If
  183. If a(1) = b(1) Then
  184. pFootInXY = Array(P(0), a(1), 0#): Exit Function
  185. End If
  186. Dim aa, bb, c, d, X, Y
  187. aa = (a(1) - b(1)) / (a(0) - b(0))
  188. bb = a(1) - aa * a(0)
  189. c = -(a(0) - b(0)) / (a(1) - b(1))
  190. d = P(1) - c * P(0)
  191. X = (d - bb) / (aa - c)
  192. Y = aa * X + bb
  193. pFootInXY = Array(X, Y, 0#)
  194. End Function
  195. Public Function FindAllShapes() As ShapeRange
  196. Dim s As Shape
  197. Dim srPowerClipped As New ShapeRange
  198. Dim sr As ShapeRange, srAll As New ShapeRange
  199. If ActiveSelection.Shapes.Count > 0 Then
  200. Set sr = ActiveSelection.Shapes.FindShapes()
  201. Else
  202. Set sr = ActivePage.Shapes.FindShapes()
  203. End If
  204. Do
  205. For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
  206. srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
  207. Next s
  208. srAll.AddRange sr
  209. sr.RemoveAll
  210. sr.AddRange srPowerClipped
  211. srPowerClipped.RemoveAll
  212. Loop Until sr.Count = 0
  213. Set FindAllShapes = srAll
  214. End Function
  215. ' ************* 函数模块 ************* '
  216. Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
  217. Dim fso
  218. Set fso = CreateObject("Scripting.FileSystemObject")
  219. ExistsFile_UseFso = fso.FileExists(strPath)
  220. Set fso = Nothing
  221. End Function
  222. Public Function test_sapi()
  223. Dim message, sapi
  224. MsgBox ("Please use the headset and listen to what I have to say...")
  225. message = "This is a simple voice test on your Microsoft Windows."
  226. Set sapi = CreateObject("sapi.spvoice")
  227. sapi.Speak message
  228. End Function
  229. ' Public Function WebHelp(url As String)
  230. ' Dim h As Longer, r As Long
  231. ' h = FindWindow(vbNullString, "Toolbar")
  232. ' r = ShellExecute(h, "", url, "", "", 1)
  233. ' End Function