frmans.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmANS 
   AutoRedraw      =   -1  'True
   Caption         =   "有限元分析"
   ClientHeight    =   6930
   ClientLeft      =   60
   ClientTop       =   525
   ClientWidth     =   8820
   LinkTopic       =   "Form1"
   ScaleHeight     =   6930
   ScaleWidth      =   8820
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdClear 
      Caption         =   "Clear"
      Height          =   375
      Left            =   6120
      TabIndex        =   6
      Top             =   0
      Width           =   975
   End
   Begin ComctlLib.StatusBar barMSG 
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   5
      Top             =   6555
      Width           =   8820
      _ExtentX        =   15558
      _ExtentY        =   661
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   3
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Text            =   "状态栏"
            TextSave        =   "状态栏"
            Key             =   "sMessage"
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   1
            Object.Width           =   9895
            Key             =   "Msg"
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel3 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Alignment       =   2
            Key             =   "abc"
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton cmdResult 
      Caption         =   "Result"
      Height          =   375
      Left            =   4920
      TabIndex        =   4
      Top             =   0
      Width           =   975
   End
   Begin VB.CommandButton cmdPlot 
      Caption         =   "Plot"
      Height          =   375
      Left            =   3720
      TabIndex        =   3
      Top             =   0
      Width           =   975
   End
   Begin VB.PictureBox picGraph 
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000017&
      Height          =   5895
      Left            =   120
      ScaleHeight     =   5835
      ScaleWidth      =   8475
      TabIndex        =   2
      Top             =   600
      Width           =   8535
   End
   Begin VB.CommandButton cmdRun 
      Caption         =   "Run"
      Height          =   375
      Left            =   2040
      TabIndex        =   1
      Top             =   0
      Width           =   1095
   End
   Begin MSComDlg.CommonDialog dlgFile 
      Left            =   0
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdRead 
      Caption         =   "read"
      Height          =   375
      Left            =   600
      TabIndex        =   0
      Top             =   0
      Width           =   1095
   End
End
Attribute VB_Name = "frmANS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private GraphScale As Double
Private GraphXc As Double, GraphYc As Double

Private Sub cmdClear_Click()
    picGraph.Cls
    SDH_MSG "CLEAR OK!"
End Sub

Private Sub cmdPlot_Click()
    PlotAll
    SDH_MSG "PLOT OK!"
End Sub

Private Sub cmdRead_Click()
    Rem 读入命令流
    Dim sPath$, sFile$, sExpt$
    sPath = MyPath & "Apdl\"
    sFile = MyDataFile
    sExpt = MyDataExpt
    If SelectFile(sPath, sFile, sExpt) = 0 Then
        If Right(UCase(sFile + "." + sExpt), Len(MyDataExpt)) = UCase(MyDataExpt) Then
            sFile = Left(sFile, Len(sFile) + Len(sExpt) + 1 - Len(MyDataExpt))
        End If
        If mdlIO.ReadApdl(sPath, sFile, "txt") = 0 Then
            AdjustGraph
            cmdPlot_Click  '显示模型
            SDH_MSG "已读入APDL文件,包含:" & Top_Node & "节点;" & Top_Elem & "单元."
        End If
    End If
    
End Sub

Private Function SelectFile(sPath$, sFile$, sExpt$, Optional nSave%) As Long
    Rem 选择一个文件
    Dim I As Integer, J As Integer, K As Integer
    Dim Str1 As String
    On Error Resume Next
    If sPath <> "" Then dlgFile.InitDir = sPath
    If sExpt <> "" Then dlgFile.Filter = "数据文件(*" + sExpt + ")|*" + sExpt + "|所有文件|*.*"
    If nSave = 0 Then
        dlgFile.ShowOpen
    Else
        dlgFile.ShowSave
    End If
    If Err.Number <> 0 Then
        SelectFile = -1
        Err.Clear
    ElseIf dlgFile.FileName <> "" Then
        Path_Name_Expt dlgFile.FileName, sPath, sFile, sExpt
    Else
        SelectFile = -1
    End If
End Function

Private Sub cmdResult_Click()
    PlotDof
    SDH_MSG "RESULT OK!"
End Sub

Private Sub cmdRun_Click()
    Call Solu
    Call Post1
    SaveDofs MyPath & "\Result\", "ANS_NSOL", "TXT"
    SDH_MSG "RUN OK!"
End Sub

Public Function AdjGraphScale(MinX!, MaxX!, MinY!, MaxY!)
    Rem 自动调整图形显示比例
    Dim uScl#, B1#, H1#
    Const MinDist = 0.00001, KScl = 1.2
    B1 = Abs(MaxX - MinX): H1 = Abs(MaxY - MinY)
    GraphXc = MinX + (MaxX - MinX) / 2
    GraphYc = MinY + (MaxY - MinY) / 2
    If B1 < MinDist Then B1 = MinDist
    If H1 < MinDist Then H1 = MinDist
    uScl = picGraph.Width / B1
    If (uScl > picGraph.Height / H1) Then uScl = picGraph.Height / H1
    GraphScale = uScl / KScl
    Dim X1!, X2!, Y1!, Y2!
    X1 = GraphXc - picGraph.Width / GraphScale / 2#
    X2 = GraphXc + picGraph.Width / GraphScale / 2#
    Y1 = GraphYc - picGraph.Height / GraphScale / 2#
    Y2 = GraphYc + picGraph.Height / GraphScale / 2#
    picGraph.Scale (X1, Y2)-(X2, Y1)
    picGraph.Cls
End Function

Public Function AddLine(Clr&, ParamArray Pnts())
    Dim P1!(2), P2!(2)
    For I = 1 To UBound(Pnts)
        P1(0) = Pnts(I - 1)(0): P1(1) = Pnts(I - 1)(1)
        P2(0) = Pnts(I)(0): P2(1) = Pnts(I)(1)
        picGraph.Line (P1(0), P1(1))-(P2(0), P2(1)), Clr
    Next
End Function

Function AddDofs(Point, Angle1#)
    Dim Pt!(2), P1!(2), P2!(2), P3!(2)
    Dim D!: D = GraphSize(2)
    Call CopyPoint(Pt, Point)
    Call P_PLR(P1, Point, Angle1 + Dtr(150), D)
    Call P_PLR(P2, Point, Angle1 - Dtr(150), D)
    Call P_MID(P3, P1, P2)
    Call AddLine(vbCyan, Point, P1, P2, Point, P3)
End Function

Function AddForce(Point, ByVal Angle1#, ByVal Value1#)
    Call AddArrow(Point, Angle1, Value1, vbRed)
End Function

Function AddReaction(Point, ByVal Angle1#, ByVal Value1#)
    Call AddArrow(Point, Angle1, Value1, vbMagenta)
End Function

Function AddArrow(Point, ByVal Angle1#, ByVal Value1#, ByVal Clr&)
    Dim Pt!(2), P1!(2), P2!(2), P3!(2)
    Dim D!: D = GraphSize(2)
    Dim R_Scl!: R_Scl = 0.4
    Call CopyPoint(Pt, Point)
    If Value1 < 0 Then Value1 = -Value1: Angle1 = Angle1 + 4 * Atn(1)
    Call P_PLR(P1, Point, Angle1, R_Scl * Value1)
    Call P_PLR(P2, P1, Angle1 + Dtr(165), D)
    Call P_PLR(P3, P1, Angle1 - Dtr(165), D)
    Call AddLine(Clr, Point, P1)
    Call AddLine(Clr, P2, P1, P3)
End Function

Private Function GraphSize(ByVal X As Single) As Single
    GraphSize = 100 * X / GraphScale
End Function

Private Sub Form_Load()
    MyPath = App.Path
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    GraphScale = 1
End Sub

Public Sub SDH_MSG(sMsg As String)
    Rem 设置提示
    barMSG.Panels("Msg").Text = "[" & Time() & "] " & sMsg
End Sub