mdlpblc.bas

用visual basic编写的有限元程序！

Attribute VB_Name = "mdlPblc"
Public MyPath As String, MyDataFile As String, MyDataExpt As String


Public Function FirstWord(ByRef SrcString As String, compart As String) As String
    Rem 通用程序,获取首字, by SDH 2004-4-17
    If InStr(1, SrcString, compart) > 0 Then
        FirstWord = Left(SrcString, InStr(1, SrcString, compart) - 1)
        SrcString = Right(SrcString, Len(SrcString) - InStr(1, SrcString, compart) - Len(compart) + 1)
    Else
        FirstWord = SrcString
        SrcString = ""
    End If
End Function


Public Sub Path_Name_Expt(ByVal FullFileName As String, FilePath As String, FileName As String, FileExpt As String)
    Dim I As Integer, J As Integer, K As Integer
    For I = 1 To Len(FullFileName)
        If Mid(FullFileName, I, 1) = "\" Then J = I
    Next
    K = Len(FullFileName)
    For I = J + 1 To Len(FullFileName)
        If Mid(FullFileName, I, 1) = "." Then K = I
    Next
    FilePath = Left(FullFileName, J)
    FileName = Right(Left(FullFileName, K - 1), K - J - 1)
    FileExpt = Right(FullFileName, Len(FullFileName) - K)
End Sub

Rem **********
Public Sub CopyPoint(Pt, P0)
    Pt(0) = P0(0): Pt(1) = P0(1)
End Sub

Public Function P_PXY(Pr, Pt, dX, dY) As Long
    Rem 3. 相对坐标,By Sdh,2005-3-2
    Pr(0) = Pt(0) + dX
    Pr(1) = Pt(1) + dY
End Function

Public Function P_PLR(Pr, Pt, Angle, Radius) As Long
    Rem 4. 相对极坐标,By Sdh,2005-3-2
    Pr(0) = Pt(0) + Radius * Cos(Angle)
    Pr(1) = Pt(1) + Radius * Sin(Angle)
End Function

Public Function P_MID(Pr1, P1, P2, Optional ByVal Scl# = 0.5)
    Rem 10. 求两点之间比例点,返回点Pr1,By Sdh,2005-12-20,Tst 2005-12-20
    Rem 提供起点P1，终点P2,比例Scl
    Pr1(0) = P1(0) + (P2(0) - P1(0)) * Scl
    Pr1(1) = P1(1) + (P2(1) - P1(1)) * Scl
End Function


Sub MsgArr(Par1#())
    Dim M&, N&
    M = UBound(Par1, 1): N = UBound(Par1, 2)
    MsgBox Array_To_Text(Par1, M, N)
End Sub

Function Array_To_Text(a#(), M&, N&) As String
    Dim RetStr As String, I&, J&
    For I = 1 To M
        For J = 1 To N
            RetStr = RetStr + " " + FmtA(a(I, J), "G7.2")
        Next
        RetStr = RetStr + vbCrLf
    Next
    Array_To_Text = RetStr
End Function

Public Function FmtA(num, ByVal Fmt As String) As String
    Dim nLen As Long, nCnt As Long, K As Long
    Dim Strlin As String, sFmt As String
    If Left(Fmt, 1) = "I" Then
        nLen = Val(Mid(Fmt, 2))
        Strlin = Right(Space(nLen) + Format(num, "0"), nLen)
    ElseIf Left(Fmt, 1) = "G" Then
        K = InStr(2, Fmt, ".")
        If K = 0 Then
            nLen = Val(Mid(Fmt, 2))
        Else
            nLen = Val(Mid(Fmt, 2, K - 1))
            nCnt = Val(Mid(Fmt, K + 1))
        End If
        sFmt = "0." + String(nCnt, "0")
        Strlin = Right(Space(nLen) + Format(num, sFmt), nLen)
    End If
    FmtA = Strlin
End Function

Public Function Rtd(R)
    Rem 弧转度,By Sdh,2006-6-4
    Rtd = R * 45# / Atn(1)
End Function
Public Function Dtr(D)
    Rem 度转弧,By Sdh,2006-6-4
    Dtr = D * Atn(1) / 45#
End Function

Public Function Atan(NumberY As Double, NumberX As Double) As Double
    Rem 反正切函数(扩充),By Sdh,2005-3-25
    Rem 结果范围 (-PI,PI]
    Dim Result As Double
    If NumberY = 0 And NumberX = 0 Then Exit Function
    If Abs(NumberY) <= Abs(NumberX) Then
        Result = Abs(Atn(NumberY / NumberX))
    Else
        Result = 2 * Atn(1) - Abs(Atn(NumberX / NumberY))
    End If
    If NumberX < 0 Then Result = 4 * Atn(1) - Result
    If NumberY < 0 Then Result = -Result
    Atan = Result
End Function

Public Function bBit(num%, N%) As Boolean
    bBit = (num And (2 ^ N)) <> 0
End Function