'线性方程组的解法
'
Sub XXFCZ(ByRef a() As Double, ByRef B() As Double)
    '高斯消元法
    'A(i,j)是系数
    'B(i)是右端项
    Dim N As Long
    Dim k As Long
    Dim L As Double
    Dim j As Long
    Dim sum As Double
    N = UBound(B)
    For k = 1 To N - 1
        For i = k + 1 To N
            L = a(i, k) / a(k, k)
            For j = k + 1 To N
                a(i, j) = a(i, j) - L * a(k, j)
            Next j
            B(i) = B(i) - L * B(k)
        Next i
    Next k '以上是消元过程
    B(N) = B(N) / a(N, N)
    For i = N - 1 To 1 Step -1
        sum = 0
        For j = i + 1 To N
            sum = sum + a(i, j) * B(j)
        Next j
        B(i) = (B(i) - sum) / a(i, i)
    Next i '以上是回代过程
End Sub


'线性方程组的解法
'    高斯消元法  方程组系数为零 也没有关系

Function GaoSi(a(), N, B())
    Dim Ipiv(50), INdxr(50), Indxc(50)
    Dim j
    Dim k
    Dim L
    Dim LL
    Dim Dum
    Dim Pivinv
    For j = 1 To N
        Ipiv(j) = 0
    Next j
    Dim i
    Dim Big
    Dim Irow
    Dim Icol

    For i = 1 To N
        Big = 0#
        For j = 1 To N
            If Ipiv(j) <> 1 Then
                For k = 1 To N
                    If Ipiv(k) = 0 Then
                        If Abs(a(j, k)) >= Big Then
                            Big = Abs(a(j, k))
                            Irow = j
                            Icol = k
                        End If
                    ElseIf Ipiv(k) > 1 Then
                        MsgBox "异常矩阵"
                    End If
                Next k
            End If
        Next j
        Ipiv(Icol) = Ipiv(Icol) + 1
        If Irow <> Icol Then
            For L = 1 To N
                Dum = a(Irow, L)
                a(Irow, L) = a(Icol, L)
                a(Icol, L) = Dum
            Next L
            Dum = B(Irow)
            B(Irow) = B(Icol)
            B(Icol) = Dum
        End If
        INdxr(i) = Irow
        Indxc(i) = Icol
        If a(Icol, Icol) = 0# Then MsgBox "异常矩阵"
        Pivinv = 1# / a(Icol, Icol)
        a(Icol, Icol) = 1#
        For L = 1 To N
            a(Icol, L) = a(Icol, L) * Pivinv
        Next L
        B(Icol) = B(Icol) * Pivinv
        For LL = 1 To N
            If LL <> Icol Then
                Dum = a(LL, Icol)
                a(LL, Icol) = 0#
                For L = 1 To N
                    a(LL, L) = a(LL, L) - a(Icol, L) * Dum
                Next L
                B(LL) = B(LL) - B(Icol) * Dum
            End If
        Next LL
    Next i
    For L = N To 1 Step -1
        If INdxr(L) <> Indxc(L) Then
            For k = 1 To N
                Dum = a(k, INdxr(L))
                a(k, INdxr(L)) = a(k, Indxc(L))
                a(k, Indxc(L)) = Dum
            Next k
        End If
    Next L
End Function
'浏览选择文件夹
Public Function ReturnFolder(lngHwnd As Long) As String
    Dim Browser As BrowseInfo
    Dim lngFolder As Long
    Dim strPath As String
    Dim strTemp As String
    
    With Browser
        .hOwner = lngHwnd
        .lpszTitle = "选择工作路径"
        .pszDisplayName = String(MAX_PATH, 0)
    End With
    
    '用空格填充字符串
    strPath = String(MAX_PATH, 0)
    '调用API函数显示文件夹列表
    lngFolder = SHBrowseForFolder(Browser)
    
    '使用API函数获取返回的路径
    If lngFolder Then
        SHGetPathFromIDList lngFolder, strPath
        strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)
        
        If (Right(strTemp, 1) <> "\") Then
            strTemp = strTemp & "\"
        End If
        
        ReturnFolder = strTemp
    End If
End Function
Function LoadLisp(LispFileName As String) As String
    Dim temp As String, Temp1 As String, temp2 As String, temp3 As String
    
    temp = GetPath
    Temp1 = "\"
    temp2 = "\\\"
    temp3 = Replace(temp, Temp1, temp2, 1, -1, vbTextCompare)
    
    LoadLisp = "(load" & Chr(34) & temp3 & "lisp\\" & LispFileName & Chr(34) & ")" & vbCr
End Function


Public Function ClickConfirm() As Boolean
  Dim objUtil As AcadUtility
  Dim varPnt As Variant
  Dim strPrmt As String
  On Error GoTo Err_Control
  'strPrmt = "Left click to confirm, right click to cancel"
  strPrmt = "鼠标左键确认，右键取消"
  Set objUtil = ThisDrawing.Utility
  varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  'No error? Then they "left clicked" (or typed a point on
  'The command line. Meh. Users are crazy.
  ClickConfirm = True
Exit_Here:
  Exit Function
Err_Control:
  'Debug.Print Err.Description; Err.Number
  Select Case Err.Number
    Case -2145320928
    'Right click with command prompt or "Enter" key
    'User input is a keyword
      Err.Clear
      Resume Exit_Here
    Case -2147352567
    'User pressed escape or clicked a toolbar
    'Method 'GetPoint' of object 'IAcadUtility' failed
      Err.Clear
      Resume Exit_Here
    Case Else
      Err.Clear
      Resume Exit_Here
  End Select
  End Function
  
Sub TC(E As AcadEntity)
    On Error Resume Next
       '填充面域
    Dim TC_Entity(0 To 0) As AcadEntity
    Dim TC As AcadHatch
    Dim TC_Name As String
    Dim TC_Type As Long
    Dim TC_Associativity As Boolean
    TC_Name = "SOLID"
    TC_Type = 0
    TC_Associativity = True
    
    Set TC = ThisDrawing.ModelSpace.AddHatch(TC_Type, TC_Name, TC_Associativity)
    
    Set TC_Entity(0) = E
    TC.AppendInnerLoop (TC_Entity)
    TC.Evaluate
    'ThisDrawing.SetVariable "HPDRAWORDER", 1
End Sub
Function AddLayer(LayerName As String)
    '判断文档之中是否存在图框系列图层
    '    如果没有，则新建该系列图层
    Dim LayerExist  As Boolean
    Dim L As AcadLayer
    For Each L In ThisDrawing.Layers
        If L.Name = LayerName Then LayerExist = True
    Next
    If LayerExist = False Then
        Set L = ThisDrawing.Layers.Add(LayerName)
        L.color = 1
    End If
End Function
'获取CAD坐标系统和屏幕像素的比值
Function ViewScreen() As Double
    Dim ScreenSize As Variant
    ScreenSize = ThisDrawing.GetVariable("screensize") '当前视口的屏幕宽度和高度
    Dim H As Variant
    H = ThisDrawing.GetVariable("viewsize") '当前视图图形的实际高度
    ViewScreen = Abs(H / ScreenSize(1))
End Function
'***************************************************
'字符串（默认空格为分隔符）转变为数组或empty
'***************************************************
Function StoDim(ByVal S As String, Optional div As String) As Variant
Dim s_len As Integer '字符串长度
Dim s_p As Integer   '查找开始位置
Dim gs() As String
Dim i As Integer
Dim j As Integer

If div = "" Then div = " "

i = 0

s_p = 1

S = LTrim(S + div)
s_len = Len(S)

j = 0
While s_p <= s_len '找到最后子串
    If Mid(S, s_p, 1) = div Then '如果找到分隔符
        '取子字符串
        If s_p > 1 Then
            ReDim Preserve gs(j)
            gs(j) = Left(S, s_p - 1)
            j = j + 1
        End If
        S = LTrim(Right(S, s_len - s_p))
        s_len = Len(S)  '替换后新串长度
        s_p = 1    '下次开始查找的位置
        i = i + 1
    Else
        s_p = s_p + 1   '如果没有找分隔符，从下一个开始
    End If
Wend

'空数组
If j = 0 Then Exit Function

StoDim = gs  '得到字符串数组

End Function

'命令行提示
Function Prompt(str As String)
  ThisDrawing.Utility.Prompt str & vbCrLf
End Function
'创建匿名组，如果有则序号加1，如果没有则创建
Function NiMingZu(S As String) As String
    Dim G As AcadGroup
    Dim N As Long
    For Each G In ThisDrawing.Groups
        If Left(G.Name, Len(S)) = S Then N = N + 1
    Next
    NiMingZu = S & N + 1
End Function
'点到直线的垂足
Function ChuiZuP2L(p1 As Variant, p2 As Variant, P3 As Variant) As Variant
    Dim M(0 To 5) As Double
    Dim T As Double
    Dim P4(2)  As Double

    '如果三点在一条直线上,则垂足就是P3点。
    '判断三点是否在一条直线上
    If ThreeP_IsOnline(p1, p2, P3) = True Then
        ChuiZuP2L = P3
    Else
        '直线P1-P2的向量{M(0),M(1),M(2)}
        M(0) = p2(0) - p1(0)
        M(1) = p2(1) - p1(1)
        M(2) = p2(2) - p1(2)
        '直线P2-P3的向量{M(3),M(4),M(5)}
        M(3) = p2(0) - P3(0)
        M(4) = p2(1) - P3(1)
        M(5) = p2(2) - P3(2)
     
        T = -(M(0) * M(3) + M(1) * M(4) + M(2) * M(5)) / (M(0) ^ 2 + M(1) ^ 2 + M(2) ^ 2)
        '垂足
        P4(0) = M(0) * T + p2(0)
        P4(1) = M(1) * T + p2(1)
        P4(2) = M(2) * T + p2(2)
        ChuiZuP2L = P4
     End If
End Function
'点排序(同一条直线上的点)
Function DianPaiXu1(ByRef Plist() As Variant)
    Dim i As Long
    i = UBound(Plist)
    Dim M As Variant
    Dim N As Variant
    Dim j As Long
    Dim L As Long
    Dim temp As Variant
    For j = 1 To i
        M = Plist(j)
        For L = j + 1 To i
            N = Plist(L)
            If M(0) + M(1) > N(0) + N(1) Then
                temp = Plist(j)
                Plist(j) = Plist(L)
                Plist(L) = temp
            End If
        Next
    Next
End Function

甲老师在批改英语作文，忽然大发雷霆：“我从来没看过这么烂的英语作文” 

乙老师见状问：“写的是什么啊？” 

甲老师：“写一个王子和公主的故事。” 

“不错啊”乙说。 

“他竟然在开头写王子问公主‘can you speak chinese?' 

公主回答‘yes', 

接下来的全部都是中文！”

2007年8月，腾讯公司动用深圳警方力量，将珊瑚虫的陈寿福从北京的家中拘捕回深圳。腾讯公司指控陈寿福通过捆绑制作珊瑚虫QQ非法获利

'返回阵风系数
'XS1 地面粗糙程度(A,B,C,D)。
'XS2 离地面高度 单位m。
'建筑结构荷载规范 GB 5009-2001 表7.5.1
'计算公式 建筑结构工程师手册 表1.4.2-2
Function ZFXS(XS1 As String, XS2 As Integer) As Double
    XS1 = UCase(XS1)
    If XS2 <= 300 Then
        Select Case XS1
            Case "A"
                ZFXS = Format(0.92 * (1 + 0.774 * (XS2 / 10) ^ (-0.12)), "0.00")
            Case "B"
                ZFXS = Format(0.89 * (1 + 1 * (XS2 / 10) ^ (-0.16)), "0.00")
            Case "C"
                ZFXS = Format(0.85 * (1 + 1.468 * (XS2 / 10) ^ (-0.22)), "0.00")
            Case "D"
                ZFXS = Format(0.8 * (1 + 2.45 * (XS2 / 10) ^ (-0.3)), "0.00")
        End Select
    End If
End Function