corelvba/zerobase/API.bas

Attribute VB_Name = "API"
'// This is free and unencumbered software released into the public domain.
'// For more information, please refer to  https://github.com/hongwenjun

'// Attribute VB_Name = "CorelVBA工具窗口启动"   CorelVBA Tool Window Launches  2023.6.11


'// CorelDRAW 窗口刷新优化和关闭
Public Function BeginOpt(Optional ByVal name As String = "Undo")
  EventsEnabled = False
  ActiveDocument.BeginCommandGroup name
' ActiveDocument.SaveSettings
  ActiveDocument.Unit = cdrMillimeter
  Optimization = True
' ActiveDocument.PreserveSelection = False
End Function

Public Function EndOpt()
' ActiveDocument.PreserveSelection = True
' ActiveDocument.RestoreSettings
  EventsEnabled = True
  Optimization = False
  EventsEnabled = True
  ActiveDocument.ReferencePoint = cdrBottomLeft
  Application.Refresh
  ActiveDocument.EndCommandGroup
End Function

Public Function Speak_Msg(message As String)
  Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0"))     '// 关停语音功能
  
  If Val(Speak_Help) = 1 Then
    Dim sapi
    Set sapi = CreateObject("sapi.spvoice")
    sapi.Speak message
  Else
    ' 不说话
  End If

End Function

Public Function GetSet(s As String)
  Bleed = Val(GetSetting("LYVBA", "Settings", "Bleed", "2.0"))
  Line_len = Val(GetSetting("LYVBA", "Settings", "Line_len", "3.0"))
  Outline_Width = Val(GetSetting("LYVBA", "Settings", "Outline_Width", "0.2"))
' Debug.Print Bleed, Line_len, Outline_Width

  If s = "Bleed" Then
    GetSet = Bleed
  ElseIf s = "Line_len" Then
    GetSet = Line_len
  ElseIf s = "Outline_Width" Then
    GetSet = Outline_Width
  End If
  
End Function

Public Function Create_Tolerance() As Double
  Dim text As String
  If GlobalUserData.Exists("Tolerance", 1) Then
    text = GlobalUserData("Tolerance", 1)
  End If
  text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
  If text = "" Then Exit Function
  GlobalUserData("Tolerance", 1) = text
  Create_Tolerance = Val(text)
End Function

Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
  Dim text As String
  If GlobalUserData.Exists("SpaceWidth", 1) Then
    text = GlobalUserData("SpaceWidth", 1)
    If OnlyRead Then
      Set_Space_Width = Val(text)
      Exit Function
    End If
  End If
  text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
  If text = "" Then Exit Function
  GlobalUserData("SpaceWidth", 1) = text
  Set_Space_Width = Val(text)
End Function

'// 获得剪贴板文本字符
Public Function GetClipBoardString() As String
  On Error Resume Next
  Dim MyData As New DataObject
  GetClipBoardString = ""
  MyData.GetFromClipboard
  GetClipBoardString = MyData.GetText
  Set MyData = Nothing
End Function

'// 文本字符复制到剪贴板
Public Function WriteClipBoard(ByVal s As String)
  On Error Resume Next

' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
#If VBA7 Then
  With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .text = s
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
  End With
#Else
  Dim MyData As New DataObject
  MyData.SetText s
  MyData.PutInClipboard
#End If
End Function

'// 换行转空格 多个空格换成一个空格
Public Function Newline_to_Space(ByVal str As String) As String
  str = VBA.Replace(str, Chr(13), " ")
  str = VBA.Replace(str, Chr(9), " ")
  Do While InStr(str, "  ")
      str = VBA.Replace(str, "  ", " ")
  Loop
  Newline_to_Space = str
End Function

'// 获得数组元素个数
Public Function arrlen(src As Variant) As Integer
  On Error Resume Next '空意味着 0 长度
  arrlen = (UBound(src) - LBound(src))
End Function

'// 对数组进行排序[单维]
Public Function ArraySort(src As Variant) As Variant
  Dim out As Long, i As Long, tmp As Variant
  For out = LBound(src) To UBound(src) - 1
    For i = out + 1 To UBound(src)
      If src(out) > src(i) Then
        tmp = src(i): src(i) = src(out): src(out) = tmp
      End If
    Next i
  Next out
  
  ArraySort = src
End Function

'//  把一个数组倒序
Public Function ArrayReverse(arr)
    Dim i As Integer, n As Integer
    n = UBound(arr)
    Dim P(): ReDim P(n)
    For i = 0 To n
        P(i) = arr(n - i)
    Next
    ArrayReverse = P
End Function

'// 测试数组排序
Private Function test_ArraySort()
  Dim arr As Variant, i As Integer
  arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
  For i = 0 To arrlen(arr) - 1
    Debug.Print arr(i);
  Next i
  Debug.Print arrlen(arr)
  ArraySort arr
  For i = 0 To arrlen(arr) - 1
    Debug.Print arr(i);
  Next i
End Function

'// 两点连线的角度：返回角度(相对于X轴的角度)
'// p为末点，O为始点
Public Function alfaPP(P, o)
    Dim pi As Double: pi = 4 * Atn(1)
    Dim beta As Double
    If P(0) = o(0) And P(1) = o(1) Then '二点重合
        alfaPP = 0
        Exit Function
    ElseIf P(0) = o(0) And P(1) > o(1) Then
        beta = pi / 2
    ElseIf P(0) = o(0) And P(1) < o(1) Then
        beta = -pi / 2
    ElseIf P(1) = o(1) And P(0) < o(0) Then
        beta = pi
    ElseIf P(1) = o(1) And P(0) > o(0) Then
        beta = 0
    Else
        beta = Atn((P(1) - o(1)) / VBA.Abs(P(0) - o(0)))
        If P(1) > o(1) And P(0) < o(0) Then
            beta = pi - beta
        ElseIf P(1) < o(1) And P(0) < o(0) Then
            beta = -(pi + beta)
        End If
    End If
    alfaPP = beta * 180 / pi
End Function

'// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
Public Function pFootInXY(P, a, b)
    If a(0) = b(0) Then
        pFootInXY = Array(a(0), P(1), 0#): Exit Function
    End If
    If a(1) = b(1) Then
        pFootInXY = Array(P(0), a(1), 0#): Exit Function
    End If
    Dim aa, bb, c, d, x, Y
    aa = (a(1) - b(1)) / (a(0) - b(0))
    bb = a(1) - aa * a(0)
    c = -(a(0) - b(0)) / (a(1) - b(1))
    d = P(1) - c * P(0)
    x = (d - bb) / (aa - c)
    Y = aa * x + bb
    pFootInXY = Array(x, Y, 0#)
End Function


Public Function FindAllShapes() As ShapeRange
  Dim s As Shape
  Dim srPowerClipped As New ShapeRange
  Dim sr As ShapeRange, srAll As New ShapeRange
  
  If ActiveSelection.Shapes.Count > 0 Then
    Set sr = ActiveSelection.Shapes.FindShapes()
  Else
    Set sr = ActivePage.Shapes.FindShapes()
  End If
  
  Do
    For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
        srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
    Next s
    srAll.AddRange sr
    sr.RemoveAll
    sr.AddRange srPowerClipped
    srPowerClipped.RemoveAll
  Loop Until sr.Count = 0
  
  Set FindAllShapes = srAll
End Function

' ************* 函数模块 ************* '
Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
     Dim fso
     Set fso = CreateObject("Scripting.FileSystemObject")
     ExistsFile_UseFso = fso.FileExists(strPath)
     Set fso = Nothing
End Function

Public Function test_sapi()
  Dim message, sapi
  MsgBox ("Please use the headset and listen to what I have to say...")
  message = "This is a simple voice test on your Microsoft Windows."
  Set sapi = CreateObject("sapi.spvoice")
  sapi.Speak message
End Function


' Public Function WebHelp(url As String)
'  Dim h As Longer, r As Long
'  h = FindWindow(vbNullString, "Toolbar")
'  r = ShellExecute(h, "", url, "", "", 1)
' End Function