用VisualBasic6.0编写的一个「铸造过程温度场模拟的程序」

20:56 2020/12/26 Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single Dim MeshColor As OLE_COLOR Private Type Unit Temp0 As Single Temp1 As Single ID As Integer End Type Private Cell() As Unit Private Sub Reset_Click() If L <> 0 Then Pic.Cls Call ShowMesh End If End Sub Private Sub CloseFile_Click() Pic.Cls End Sub Private Sub Pic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Coords.Caption = " 当前点的横坐标 X 为 " & Format(X, 0) & _ " 当前点的纵坐标 Y 为 " & Format(Y, 0) End Sub Private Sub Exit_Click() End End Sub Private Sub Parameters_Click() Form2.Show End Sub Private Sub Form_Load() Form1.AutoRedraw = True Pic.AutoRedraw = True Form1.Caption = "Cast" Form1.Height = 10000 Form1.Width = 10500 Coords.Left = Form1.ScaleLeft Coords.Height = 255 'Coords.Width = Form1.ScaleWidth Pic.Left = Form1.ScaleLeft Pic.Top = Form1.ScaleTop Pic.Height = Form1.ScaleHeight - Coords.Height Pic.Width = Form1.ScaleHeight Pic.BackColor = vbBlack Coords.Top = Pic.Top + Pic.Height Call ColorMark End Sub '============================绘制色标========================= Private Sub ColorMark() Label1.Top = Pic.Top Label1.Left = Pic.Left + Pic.Width Label1.BackColor = vbBlack Label1.Height = Pic.Height Label1.Width = 1210 For i = 0 To 15 Shape1(i).Width = 495 Shape1(i).Height = 975 Shape1(i).Left = Label1.Left + 150 Shape1(i).Top = Label1.Top - i * 495 + 7800 Label2(i).Top = Shape1(i).Top + 600 Label2(i).Left = Shape1(i).Left + 550 Label2(i).Caption = i * 100 Next i Label2(16).Top = Shape1(15).Top + 200 Label2(16).Left = Shape1(15).Left + 550 Label2(i).Caption = "色标" Shape1(0).BackColor = RGB(22, 0, 153) Shape1(1).BackColor = RGB(0, 0, 205) Shape1(2).BackColor = RGB(0, 85, 255) Shape1(3).BackColor = RGB(0, 170, 255) Shape1(4).BackColor = RGB(0, 255, 255) Shape1(5).BackColor = RGB(0, 242, 161) Shape1(6).BackColor = RGB(0, 255, 0) Shape1(7).BackColor = RGB(128, 255, 0) Shape1(8).BackColor = RGB(213, 255, 0) Shape1(9).BackColor = RGB(255, 255, 0) Shape1(10).BackColor = RGB(255, 212, 0) Shape1(11).BackColor = RGB(255, 170, 0) Shape1(12).BackColor = RGB(255, 127, 0) Shape1(13).BackColor = RGB(255, 85, 0) Shape1(14).BackColor = RGB(255, 0, 0) Shape1(15).BackColor = RGB(215, 0, 0) End Sub '============================导入数据========================= '2020/12/24/20:34:02，把mesh()放到循环外面，极大提高文件载入速度 '2020/12/25，照葫芦画瓢，根据昨晚的灵感，优化了数据导入的代码 '2020/12/25/15:08:55 '突然想试一下不等网格能否导入，没想到真的不行，搞笑呢吧，，，？？ ' 6 minutes later ， good huaqigo finally debuged it ' 以前将 L / Dx 的值当作行数， L / Dy 当作列数，等网格的时候看不出问题(o|o) ' 排错方法是将二维数组得到的结果输出到屏幕，发现右侧有几列 0 ，说明数组边界定义不对 '2020/12/26,考研第一天，祝朋友们考试顺利！ '19:06:58 '在写温度场计算模块的时候，感觉数组和坐标方向不对应的感觉太不好了，干脆狠了狠心，花了点时间把数组纵向调了个个 '光这样还不行，数组的行对应的还是纵坐标; （（（行输入到数组的列 Private Sub Input_Click() On Error GoTo Cancel CommonDialog1.FileName = "mesh" CommonDialog1.InitDir = App.Path CommonDialog1.Filter = "Plain text(*.txt)|*.txt|Markdown(*.md)|*.md" CommonDialog1.FilterIndex = 1 CommonDialog1.CancelError = True CommonDialog1.ShowOpen Open CommonDialog1.FileName For Input As #1 Dim str As String '==========网格参数========== Do Input #1, str Loop Until InStr(str, "L Δx Δy") Input #1, L, Dx, Dy Call Rescale ''==========材料设置========== ' Do Until InStr(str, "Materials") ' Input #1, str ' Loop ' ' Dim str1$, str2$, str3$, str4$ ' Input #1, str1, str2, str3, str4 ' Pic.Print str1 ' Pic.Print str2 ' Pic.Print str3 ' Pic.Print str4 '==========网格数据========== Do Until InStr(str, "Casting&Material") Input #1, str Loop Dim r As Integer, c As Integer r = L / Dy c = L / Dx ReDim Cell(1 To c, 1 To r) '动态数组重新定义 i = 0 '2020/12/25 Do Until EOF(1) ' 分清行和列，l/dy 对应行数 Dim s As String Input #1, s ' i 记录行号，从上到下 For j = 1 To Len(s) Step 2 ' j记录列号，从左到右 If Val(Mid(s, j, 1)) = 4 Then ' module1冒口和铸件的颜色不一样 Cell((j + 1) / 2, r - i).ID = 1 ' 这里统一一下 Else Cell((j + 1) / 2, r - i).ID = Val(Mid(s, j, 1)) End If Next j i = i + 1 Loop Close #1 Call ShowMesh Exit Sub Cancel: End Sub Private Sub ShowMesh() Dim r As Integer, c As Integer r = L / Dy c = L / Dx For i = 1 To c For j = 1 To r Select Case Cell(i, j).ID Case 0 MeshColor = vbWhite Case 1 MeshColor = vbRed Case 2 MeshColor = vbGreen Case 3 MeshColor = vbBlue Case 4 MeshColor = vbYellow End Select X2 = i * Dx X1 = X2 - Dx Y2 = j * Dy Y1 = Y2 - Dy Pic.Line (X1, Y1)-(X2, Y2), MeshColor, BF Next i Call Mesh End Sub Private Sub Mesh() Pic.ForeColor = RGB(50, 50, 50) For i = 0 To L Step Dx Pic.Line (i, 0)-(i, L) Next i For i = 0 To L Step Dy Pic.Line (0, i)-(L, i) Next i End Sub Private Sub Rescale() Pic.Cls Pic.Scale (-5, L + 5)-(L + 5, -5) Call Mesh End Sub Private Sub Calculate() Dim yr As Integer, xc As Integer yr = L / Dy xc = L / Dx For i = 1 To xc For j = 1 To yr If Cell(i, j).ID <> 0 Then '空气的温度不进行计算 If i = 1 Then If j <> 1 And j <> yr Then '左边界单元 Cell(i, j).Temp1 = Dt / (Cp(Cell(i, j).ID) * Rho(Cell(i, j).ID)) _ * (Ha * (T(0) - Cell(i, j).Temp0) / Dx _ + Kh(Cell(i, j).ID, Cell(i + 1, j).ID) * (Cell(i + 1, j).Temp0 - Cell(i, j).Temp0) / (3 / 2 * Dx ^ 2) _ + Kh(Cell(i, j).ID, Cell(i, j + 1).ID) * (Cell(i, j + 1).Temp0 - Cell(i, j).Temp0) / Dy ^ 2 _ + Kh(Cell(i, j).ID, Cell(i, j - 1).ID) * (Cell(i, j - 1).Temp0 - Cell(i, j).Temp0) / Dy ^ 2) _ + Cell(i, j).Temp0 End If ElseIf i = xc Then If j <> 1 And j <> yr Then '右边界单元 Cell(i, j).Temp1 = Dt / (Cp(Cell(i, j).ID) * Rho(Cell(i, j).ID)) _ * (Kh(Cell(i, j).ID, Cell(i - 1, j).ID) * (Cell(i - 1, j).Temp0 - Cell(i, j).Temp0) / (3 / 2 * Dx ^ 2) _ + Ha * (T(0) - Cell(i, j).Temp0) / Dx _ + Kh(Cell(i, j).ID, Cell(i, j + 1).ID) * (Cell(i, j + 1).Temp0 - Cell(i, j).Temp0) / Dy ^ 2 _ + Kh(Cell(i, j).ID, Cell(i, j - 1).ID) * (Cell(i, j - 1).Temp0 - Cell(i, j).Temp0) / Dy ^ 2) _ + Cell(i, j).Temp0 End If ElseIf j = 1 Then If i <> 1 And i <> xc Then