| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
投票:[转帖]难道众多高手的vb解方程题
 
1 票:50.00%
 
0 票:0.00%
 
1 票:50.00%
 
0 票:0.00%
 
0 票:0.00%
 
0 票:0.00%
 
0 票:0.00%
 
0 票:0.00%
 
0 票:0.00%
 
0 票:0.00%
    您没有登录,无法进行投票和查看投票结果,请登录论坛  [总票数 2 票  截止时间 2033-2-2 16:32]

标题:[转帖]难道众多高手的vb解方程题
收藏  订阅  推荐  打印
哀思
Rank: 1
等级:新手上路
帖子:2
积分:120
注册:2005-9-18
[转帖]难道众多高手的vb解方程题

Public Function Determinant(m() As Single) As Single Dim i As Long, j As Long, k As Long, row As Long, order As Long Dim r As Long, c As Long, Pivot As Single, Pivot2 As Single, temp() As Single Determinant = 1 row = UBound(m, 1) If UBound(m, 2) <> row Then MsgBox "这不是方阵": Exit Function ReDim temp(1 To row) For i = 1 To row Pivot = 0 For j = i To row For k = i To row If Abs(m(k, j)) > Pivot Then Pivot = Abs(m(k, j)) r = k: c = j End If Next k Next j If Pivot = 0 Then Determinant = 0: Exit Function If r <> i Then order = order + 1 For j = 1 To row temp(j) = m(i, j) m(i, j) = m(r, j) m(r, j) = temp(j) Next j End If If c <> i Then order = order + 1 For j = 1 To row temp(j) = m(j, i) m(j, i) = m(j, c) m(j, c) = temp(j) Next j End If Pivot = m(i, i) Determinant = Determinant * Pivot For j = i + 1 To row Pivot2 = m(j, i) If Pivot2 <> 0 Then For k = 1 To row m(j, k) = m(j, k) - m(i, k) * Pivot2 / Pivot Next End If Next Next Determinant = Determinant * (-1) ^ order End Function

Private Sub Command1_Click() Dim Keyin As String, m() As Single Keyin = InputBox("请输入方阵(square matrix),& vbNewLine& vbNewLine ")

If SepStrToMatrix(Keyin, ";", " ", m) Then Debug.Print Determinant(m) Else MsgBox "矩阵输入有误,请重新输入。" End If End Sub Public Function SepStrToMatrix(TreatStr As String, RowSepChr As String, _ ColSepChr As String, Returnvalue() As Single) As Boolean If StrComp(RowSepChr, ColSepChr, vbBinaryCompare) = 0 Then _ MsgBox "列和行的分隔字元不可相同" Dim i As Long, j As Long, k As Long, temp As String, no As Long Dim row As Long, SepStr() As String TreatStr = Trim(TreatStr) Do no = no + 1 ReDim Preserve SepStr(1 To no) i = InStr(j + 1, TreatStr, RowSepChr, vbBinaryCompare) If i <> 0 Then SepStr(no) = Trim(Mid(TreatStr, j + 1, i - j - 1)) Else SepStr(no) = Trim(Mid(TreatStr, j + 1)) End If j = i Loop Until i = 0 row = no ReDim Returnvalue(1 To row, 1 To 1) For k = 1 To row no = 0 Do i = InStr(j + 1, SepStr(k), ColSepChr, vbBinaryCompare) If i <> j + 1 Then no = no + 1 If i <> 0 Or (i = 0 And j < Len(SepStr(k))) Then If i <> 0 Then temp = Mid(SepStr(k), j + 1, i - j - 1) Else _ temp = Mid(SepStr(k), j + 1) If Not IsNumeric(temp) Or InStr(temp, ",") > 0 Then Exit Function If no > UBound(Returnvalue, 2) Then _ ReDim Preserve Returnvalue(1 To row, 1 To no) Returnvalue(k, no) = temp End If End If j = i Loop Until i = 0 Next SepStrToMatrix = True End Function

2005-09-18 16:32



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.051642 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved