www.pudn.com > Doe.rar > FrmCaculate.frm
VERSION 5.00
Object = "{0ECD9B60-23AA-11D0-B351-00A0C9055D8E}#6.0#0"; "MSHFLXGD.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Begin VB.Form FrmCaculate
BorderStyle = 1 '單線固定
Caption = "變異數分析表"
ClientHeight = 9180
ClientLeft = 45
ClientTop = 330
ClientWidth = 9495
Icon = "FrmCaculate.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MDIChild = -1 'True
MinButton = 0 'False
ScaleHeight = 9180
ScaleMode = 0 '使用者自訂
ScaleWidth = 10000
Begin VB.CommandButton Command1
Caption = "初值"
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3000
TabIndex = 14
Top = 8640
Width = 1575
End
Begin MSDataGridLib.DataGrid ResDG
Height = 2175
Left = 360
TabIndex = 13
Top = 6000
Width = 8775
_ExtentX = 15478
_ExtentY = 3836
_Version = 393216
AllowUpdate = -1 'True
Appearance = 0
HeadLines = 1
RowHeight = 19
FormatLocked = -1 'True
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "新細明體"
Size = 9.75
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 6
BeginProperty Column00
DataField = ""
Caption = "FACTOR"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1028
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = ""
Caption = "SI"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1028
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column02
DataField = ""
Caption = "DF"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1028
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column03
DataField = ""
Caption = "V"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1028
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column04
DataField = ""
Caption = "F"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1028
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column05
DataField = ""
Caption = "@(%)"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1028
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
Alignment = 2
ColumnWidth = 1579.878
EndProperty
BeginProperty Column01
Alignment = 1
Locked = -1 'True
ColumnWidth = 1374.482
EndProperty
BeginProperty Column02
Alignment = 2
Locked = -1 'True
ColumnWidth = 837.109
EndProperty
BeginProperty Column03
Alignment = 1
Locked = -1 'True
ColumnWidth = 1374.482
EndProperty
BeginProperty Column04
Alignment = 1
Locked = -1 'True
ColumnWidth = 1374.482
EndProperty
BeginProperty Column05
Alignment = 1
Locked = -1 'True
ColumnWidth = 1374.482
EndProperty
EndProperty
End
Begin VB.CommandButton cmdMerge
Caption = "合併計算"
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 360
TabIndex = 10
Top = 8640
Width = 1935
End
Begin VB.CommandButton cmdExport
Caption = "匯出"
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 5400
TabIndex = 9
Top = 8640
Width = 1575
End
Begin VB.CommandButton cmdExit
Caption = "離開"
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 7560
TabIndex = 8
Top = 8640
Width = 1575
End
Begin MSHierarchicalFlexGridLib.MSHFlexGrid AnoGrid
Height = 2175
Left = 360
TabIndex = 3
Top = 3240
Width = 8775
_ExtentX = 15478
_ExtentY = 3836
_Version = 393216
AllowUserResizing= 3
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty FontFixed {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "新細明體"
Size = 9.75
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_NumberOfBands = 1
_Band(0).Cols = 2
End
Begin MSHierarchicalFlexGridLib.MSHFlexGrid VarGrid
Height = 2175
Left = 360
TabIndex = 2
Top = 480
Width = 8775
_ExtentX = 15478
_ExtentY = 3836
_Version = 393216
AllowUserResizing= 3
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty FontFixed {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "新細明體"
Size = 9.75
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_NumberOfBands = 1
_Band(0).Cols = 2
End
Begin VB.Label Label7
Alignment = 2 '置中對齊
Height = 255
Left = 2760
TabIndex = 12
Top = 8280
Width = 3135
End
Begin VB.Label Label8
Alignment = 2 '置中對齊
Height = 255
Left = 5760
TabIndex = 11
Top = 8280
Width = 3135
End
Begin VB.Label Label6
Alignment = 2 '置中對齊
Height = 255
Left = 5760
TabIndex = 7
Top = 5520
Width = 3135
End
Begin VB.Label Label5
Alignment = 2 '置中對齊
Height = 255
Left = 2760
TabIndex = 6
Top = 5520
Width = 3135
End
Begin VB.Label Label4
Alignment = 2 '置中對齊
Height = 255
Left = 2760
TabIndex = 5
Top = 2760
Width = 3135
End
Begin VB.Label Label3
Caption = "ANOVA RESULT : "
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 360
TabIndex = 4
Top = 5640
Width = 8775
End
Begin VB.Label Label2
Caption = "ANOVA : "
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 360
TabIndex = 1
Top = 2880
Width = 8775
End
Begin VB.Label Label1
Caption = "VARIANCE : "
BeginProperty Font
Name = "新細明體"
Size = 12
Charset = 136
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 360
TabIndex = 0
Top = 120
Width = 8775
End
End
Attribute VB_Name = "FrmCaculate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public CalLNo As String '傳回直交表種類
Public eFileID As Long '傳回 FileID, 以進行資料匯出
Public eFacNum As Integer '傳回直交表最大因子數
Public eFacRows As Integer '傳回直交表列數
'dim vachart tp prepare calculate
Dim crsTemp As Recordset '用來暫存直交表格式
Dim rsMergeStd As Recordset '用來連接ResGrid
Dim rsMergeTemp As Recordset '用來作為合併計算用的中繼站( RS )
Dim LastData As Single '用來存最後的 V 值, 以便於計算
Dim AllDataValue As Single '用來存 SI 的總和, 以便於計算
Dim pDataValue As Single '用來存 @(%) 的總和, 以便於計算最後一欄( 最後一欄 = 100 - pDataValue )
Private Sub cmdExit_Click()
'exit form
Unload Me
End Sub
Private Sub cmdExport_Click()
'dim Vachart for ClipBoard
Dim rsExportExcel As Recordset
Dim rsFileSet As Recordset
Dim ClipTemp(5) As String
Dim clipAll As String
'dim Vachart for Excel
Dim objExcelApp As Excel.Application
Dim gnSheetNo As Integer
Dim objSheet As Excel.Worksheet
Dim rsExcel As Recordset
Dim nSQL As String
Dim ExcelModuleString As String
Dim NewModule
'存入相關資料於 ClipTemp(0)
ClipTemp(0) = ""
ClipTemp(0) = ClipTemp(0) & "eFacNum" & vbTab & eFacNum & vbCrLf '直交表最大因子數
ClipTemp(0) = ClipTemp(0) & "eFacRows" & vbTab & eFacRows & vbCrLf '直交表列數
ClipTemp(0) = ClipTemp(0) & "DGRows" & vbTab & rsMergeStd.RecordCount & vbCrLf '合併計算後列數
'存入直交表於 ClipBoard(1)
ClipTemp(1) = "直交表格式" & vbCrLf
strSQL = "select * from FileFactor where FileId = " & eFileID & " order by FactorNo ,FIndex "
Set rsFileSet = CreatRS(strSQL)
If rsFileSet.RecordCount > 0 Then
With rsFileSet
For i = 0 To eFacRows
cSearch = "FIndex = " & i
.Filter = cSearch
.Sort = "FactorNo"
.MoveFirst
If i = 0 Then
ClipTemp(1) = ClipTemp(1) & "Row" & vbTab
Else
ClipTemp(1) = ClipTemp(1) & i & vbTab
End If
For j = 1 To eFacNum
ClipTemp(1) = ClipTemp(1) & .Fields(2).Value & vbTab
.MoveNext
Next j
ClipTemp(1) = ClipTemp(1) & vbCrLf
Next i
ClipTemp(1) = ClipTemp(1) & vbCrLf '此行目的在分割不同表格
End With
End If
'存入 Data 於 ClipBoard(2)
strSQL = "select * from Rmeas where FileID =" & eFileID & " order by mIndex "
Set rsExportExcel = CreatRS(strSQL)
With rsExportExcel
If .RecordCount > 0 Then '存入ClipTemp(2)
.MoveFirst
ClipTemp(2) = "實驗數據資料表" & vbCrLf
ClipTemp(2) = ClipTemp(2) & "Row" & vbTab
For i = 1 To 5
ClipTemp(2) = ClipTemp(2) & "第 " & i & " 組" & vbTab
Next i
ClipTemp(2) = ClipTemp(2) & "平均值" & vbTab & vbCrLf
For i = 1 To .RecordCount
ClipTemp(2) = ClipTemp(2) & i & vbTab
For k = 2 To 7
If .Fields(k).Value <> -9999 Then
ClipTemp(2) = ClipTemp(2) & .Fields(k).Value & vbTab
Else
ClipTemp(2) = ClipTemp(2) & vbTab
End If
Next k
ClipTemp(2) = ClipTemp(2) & vbCrLf
.MoveNext
Next i
ClipTemp(2) = ClipTemp(2) & vbCrLf '此行目的在分割不同表格
Else
MsgBox "檔案連結錯誤, 請重新開啟檔案. ", vbOKOnly + vbCritical, "錯誤訊息"
Exit Sub
End If
End With
'存入 Variance 於 ClipBoard(3)
ClipTemp(3) = "VARIANCE : " & vbCrLf
With VarGrid
For i = 0 To .Rows - 1
For j = 0 To .Cols - 1
ClipTemp(3) = ClipTemp(3) & .TextMatrix(i, j) & vbTab
Next j
ClipTemp(3) = ClipTemp(3) & vbCrLf
Next i
ClipTemp(3) = ClipTemp(3) & vbCrLf '此行目的在分割不同表格
End With
'存入 Anova 於 ClipBoard(4)
ClipTemp(4) = "ANOVA : " & vbCrLf
With AnoGrid
For i = 0 To .Rows - 1
For j = 0 To .Cols - 1
ClipTemp(4) = ClipTemp(4) & .TextMatrix(i, j) & vbTab
Next j
ClipTemp(4) = ClipTemp(4) & vbCrLf
Next i
ClipTemp(4) = ClipTemp(4) & vbCrLf '此行目的在分割不同表格
End With
'存入 Anova result 於 ClipBoard(5)
ClipTemp(5) = "ANOVA RESULT : " & vbCrLf
For i = 0 To AnoGrid.Cols - 1
ClipTemp(5) = ClipTemp(5) & AnoGrid.TextMatrix(0, i) & vbTab
Next i
ClipTemp(5) = ClipTemp(5) & vbCrLf
With rsMergeStd
.MoveFirst
For i = 1 To .RecordCount
For j = 1 To 6
ClipTemp(5) = ClipTemp(5) & .Fields(j) & vbTab
Next j
ClipTemp(5) = ClipTemp(5) & vbCrLf
.MoveNext
Next i
ClipTemp(5) = ClipTemp(5) & vbCrLf '此行目的在分割不同表格
End With
'to get all ClipBoard
clipAll = ""
For i = 0 To 5
clipAll = clipAll & ClipTemp(i)
Next i
'save to clipboard
Clipboard.Clear
Clipboard.SetText clipAll, vbCFText
'Open Connection
If isExcelOpen = False Then
Call ExcelCN
End If
'------------------------------------------------------------------------------------------------------
'@~@ 建立 Excel 的 Application 物件
Screen.MousePointer = vbHourglass
Set objExcelApp = CreateObject("Excel.Application")
gnSheetNo = 0
On Error Resume Next
If Err.Number <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
gnSheetNo = 0
End If
Err.Clear
On Error GoTo RR
'---------------------------------------------------------------------------
'載入sample
With objExcelApp
' If .Workbooks.Count = 0 Then ' 第一次未建立 BOOK 時建立 Book
.Workbooks.Add
' Else ' 否則建立 Sheet
' .Worksheets.Add
' End If
' 顯示 EXCEL 的畫面
gnSheetNo = gnSheetNo + 1
Set objSheet = .ActiveWorkbook.ActiveSheet
.Visible = True
End With
'
' With objExcelApp
' .Workbooks.Add Template:=App.Path & "\" & "CanonSample.xlt"
' Set objSheet = objExcelApp.ActiveWorkbook.ActiveSheet
' .Visible = True
' End With
'---------------------------------------------------------------------------
'填入 Title 資料 ( Include title text and 測定器資料 )
'載入 Title
' .Cells(1, 20) = rsExportExcel.RecordCount
' .Cells(2, 3) = Text2.Text
' .Cells(3, 4) = Text1.Text
' .Range("F3:K4").Select
' .ActiveCell.FormulaR1C1 = Text3.Text & "部品測定"
'載入測定器 ( 暫時先寫死 )
'---------------------------------------------------------------------------
'@~@ 用巨集匯出
nSQL = "Select * from dExcelModule"
Set rsExcel = New ADODB.Recordset
rsExcel.Open nSQL, cnExcel, adOpenKeyset, adLockReadOnly
rsExcel.MoveFirst
ExcelModuleString = rsExcel.Fields("sResultExcel")
rsExcel.Close
Set rsExcel = Nothing
Open App.Path & "\ExcelModule.txt" For Output As #1 '建立文件
Print #1, ExcelModuleString
Close #1
'進行excel 匯出，使用excel巨集
Set NewModule = objExcelApp.ActiveWorkbook.Modules.Add '將excelmodule巨集移轉到目前使用中的excel檔案
NewModule.InsertFile FileName:=App.Path & "\ExcelModule.txt"
ExcelModuleString = ""
Open App.Path & "\ExcelModule.txt" For Output As #1 '清除
Print #1, ExcelModuleString
Close #1
objExcelApp.ActiveWorkbook.RunAutoMacros which:=xlAutoOpen
Screen.MousePointer = vbDefault
Exit Sub
RR:
MsgBox "Excel Err. : " & Err.Number & " - " & Err.Description
Screen.MousePointer = vbDefault
End Sub
Private Sub cmdMerge_Click()
Dim SumTemp As Single
Dim NumTemp As Integer, IndexTemp As Integer
Dim CalTemp As Single, pTemp As Single
SumTemp = 0
NumTemp = 0
CalTemp = 0
LastData = 0
pDataValue = 0
IndexTemp = 0
cmdMerge.Enabled = False
FrmCaculate.Enabled = False
'---------------------------------------------------------
'to get rstemp
Set rsMergeTemp = New Recordset
If rsMergeTemp.State <> adStateClosed Then rsMergeTemp.Close
With rsMergeTemp
' .Fields.Append "FacID", adInteger '紀錄控制因子順序 0
.Fields.Append "FacName", adBSTR '紀錄控制因子名稱 1
.Fields.Append "FacSI", adSingle '控制因子的 SI 值 2
.Fields.Append "FacDF", adInteger '控制因子的 DF 值 ( 自由度 ) 3
.Fields.Append "FacIndex", adInteger '控制因子的順序 4
If .State = adStateClosed Then .Open
If rsMergeStd.RecordCount > 0 Then
rsMergeStd.MoveFirst
For i = 1 To rsMergeStd.RecordCount
' .Fields(0).Value = rsMergeStd.Fields(0).Value
If rsMergeStd.Fields(1).Value = "e" Then
SumTemp = SumTemp + rsMergeStd.Fields(2).Value 'SI
NumTemp = NumTemp + rsMergeStd.Fields(3).Value 'DF
Else
IndexTemp = IndexTemp + 1
.AddNew
.Fields(0).Value = rsMergeStd.Fields(1).Value 'Name
.Fields(1).Value = rsMergeStd.Fields(2).Value 'SI
.Fields(2).Value = rsMergeStd.Fields(3).Value 'DF
.Fields(3).Value = IndexTemp
.Update
End If
rsMergeStd.MoveNext
Next i
End If
If NumTemp > 0 Then
.AddNew
.Fields(0).Value = "e" 'Name
.Fields(1).Value = SumTemp 'SI
.Fields(2).Value = NumTemp 'DF
.Fields(3).Value = IndexTemp + 1
.Update
End If
If .RecordCount > 0 Then
' .Sort="IndexTemp"
.MoveLast
LastData = cLaiFormat((.Fields(1).Value / .Fields(2).Value), 3)
If LastData = 0 Then
MsgBox "SI最小值不可為 0 ", vbOKOnly + vbCritical, "錯誤訊息"
FrmCaculate.Enabled = True
cmdMerge.Enabled = True
Exit Sub
End If
End If
End With
'---------------------------------------
Set ResDG.DataSource = Nothing
Set rsMergeStd = Nothing
Set rsMergeStd = New Recordset
If rsMergeStd.State <> adStateClosed Then rsMergeStd.Close
With rsMergeStd
.Fields.Append "FacID", adInteger '紀錄控制因子順序 0
.Fields.Append "FacName", adBSTR '紀錄控制因子名稱 1
.Fields.Append "FacSI", adSingle '控制因子的 SI 值 2
.Fields.Append "FacDF", adInteger '控制因子的 DF 值 ( 自由度 ) 3
.Fields.Append "FacV", adSingle '控制因子的 V 值 4
.Fields.Append "FacF", adSingle '控制因子的 F 值 5
.Fields.Append "FacP", adSingle '控制因子的 @(%) 值 6
If .State = adStateClosed Then .Open
If rsMergeTemp.RecordCount > 0 Then
rsMergeTemp.MoveFirst
For i = 1 To rsMergeTemp.RecordCount
.AddNew
.Fields("FacID").Value = i
.Fields("FacName").Value = rsMergeTemp.Fields(0).Value
.Fields("FacSI").Value = rsMergeTemp.Fields(1).Value
.Fields("FacDF").Value = rsMergeTemp.Fields(2).Value
'---------------------------------------------------------------------------------------------------------------------
'需做公式確認
CalTemp = cLaiFormat((rsMergeTemp.Fields(1).Value / rsMergeTemp.Fields(2).Value), 3)
.Fields("FacV").Value = CalTemp
If i <> rsMergeTemp.RecordCount Then
.Fields("FacF").Value = cLaiFormat(CalTemp / LastData, 3)
End If
If i <> rsMergeTemp.RecordCount Then
pTemp = cLaiFormat(100 * ((rsMergeTemp.Fields(1).Value - LastData) / AllDataValue), 3)
.Fields("FacP").Value = Abs(pTemp)
pDataValue = pDataValue + Abs(pTemp)
Else
.Fields("FacP").Value = cLaiFormat((100 - pDataValue), 3)
End If
'---------------------------------------------------------------------------------------------------------------------
.Update
rsMergeTemp.MoveNext
Next i
End If
End With
Call setResGrid
FrmCaculate.Enabled = True
cmdMerge.Enabled = True
End Sub
Private Sub Command1_Click()
'設定 ResultGrid
'to get rsMerge
Set ResDG.DataSource = Nothing
Set rsMergeStd = Nothing
Set rsMergeStd = New Recordset
If rsMergeStd.State <> adStateClosed Then rsMergeStd.Close
With rsMergeStd
.Fields.Append "FacID", adInteger '紀錄控制因子順序
.Fields.Append "FacName", adBSTR '紀錄控制因子名稱
.Fields.Append "FacSI", adSingle '控制因子的 SI 值
.Fields.Append "FacDF", adInteger '控制因子的 DF 值 ( 自由度 )
.Fields.Append "FacV", adSingle '控制因子的 V 值
.Fields.Append "FacF", adSingle '控制因子的 F 值
.Fields.Append "FacP", adSingle '控制因子的 @(%) 值
If .State = adStateClosed Then .Open
For i = 1 To AnoGrid.Rows - 1
.AddNew
.Fields(0).Value = i
.Fields(1).Value = AnoGrid.TextMatrix(i, 0)
.Fields(2).Value = AnoGrid.TextMatrix(i, 1)
.Fields(3).Value = AnoGrid.TextMatrix(i, 2)
.Fields(4).Value = AnoGrid.TextMatrix(i, 3)
If AnoGrid.TextMatrix(i, 4) <> "--" Then
.Fields(5).Value = AnoGrid.TextMatrix(i, 4)
End If
If AnoGrid.TextMatrix(i, 5) <> "--" Then
.Fields(6).Value = AnoGrid.TextMatrix(i, 5)
End If
.Update
Next i
End With
Call setResGrid
Label7.Caption = Label5.Caption
Label8.Caption = Label6.Caption
End Sub
Private Sub Form_Load()
'設定 VarGrid
AllDataValue = 0
pDataValue = 0
Call setVarGrid
'設定 AnoGrid
Set crsTemp = New Recordset
Set crsTemp = rsStdData.Clone
Call setAnoGrid
'設定 ResultGrid
'to get rsMerge
Set rsMergeStd = New Recordset
If rsMergeStd.State <> adStateClosed Then rsMergeStd.Close
With rsMergeStd
.Fields.Append "FacID", adInteger '紀錄控制因子順序
.Fields.Append "FacName", adBSTR '紀錄控制因子名稱
.Fields.Append "FacSI", adSingle '控制因子的 SI 值
.Fields.Append "FacDF", adInteger '控制因子的 DF 值 ( 自由度 )
.Fields.Append "FacV", adSingle '控制因子的 V 值
.Fields.Append "FacF", adSingle '控制因子的 F 值
.Fields.Append "FacP", adSingle '控制因子的 @(%) 值
If .State = adStateClosed Then .Open
For i = 1 To AnoGrid.Rows - 1
.AddNew
.Fields(0).Value = i
.Fields(1).Value = AnoGrid.TextMatrix(i, 0)
.Fields(2).Value = AnoGrid.TextMatrix(i, 1)
.Fields(3).Value = AnoGrid.TextMatrix(i, 2)
.Fields(4).Value = AnoGrid.TextMatrix(i, 3)
If AnoGrid.TextMatrix(i, 4) <> "--" Then
.Fields(5).Value = AnoGrid.TextMatrix(i, 4)
End If
If AnoGrid.TextMatrix(i, 5) <> "--" Then
.Fields(6).Value = AnoGrid.TextMatrix(i, 5)
End If
.Update
Next i
End With
Call setResGrid
End Sub
Private Sub setVarGrid()
With VarGrid
.Cols = 6
.Rows = rsStdData.RecordCount + 1
.TextMatrix(0, 0) = "COL"
.TextMatrix(0, 1) = "FACTOR"
.TextMatrix(0, 2) = "SI"
.TextMatrix(0, 3) = "AVE(L1)"
.TextMatrix(0, 4) = "AVE(L2)"
.TextMatrix(0, 5) = "AVE(L3)"
If rsStdData.RecordCount > 0 Then
rsStdData.MoveFirst
For i = 1 To rsStdData.RecordCount
.TextMatrix(i, 0) = rsStdData.Fields(0).Value
.TextMatrix(i, 1) = rsStdData.Fields(1).Value
.TextMatrix(i, 2) = rsStdData.Fields(2).Value
If IsNull(rsStdData.Fields(3).Value) Or rsStdData.Fields(3).Value = "" Then
.TextMatrix(i, 3) = "--"
Else
.TextMatrix(i, 3) = rsStdData.Fields(3).Value
End If
If IsNull(rsStdData.Fields(4).Value) Or rsStdData.Fields(4).Value = "" Then
.TextMatrix(i, 4) = "--"
Else
.TextMatrix(i, 4) = rsStdData.Fields(4).Value
End If
If IsNull(rsStdData.Fields(5).Value) Or rsStdData.Fields(5).Value = "" Then
.TextMatrix(i, 5) = "--"
Else
.TextMatrix(i, 5) = rsStdData.Fields(5).Value
End If
AllDataValue = AllDataValue + rsStdData.Fields(2).Value
rsStdData.MoveNext
Next i
End If
'資料置中
For k = 0 To .Cols - 1
.ColAlignmentFixed(k) = 4
Next k
Label4.Caption = "St = " & AllDataValue
End With
End Sub
Private Sub setAnoGrid()
With AnoGrid
crsTemp.Sort = "FacSI Desc"
.Cols = 6
.Rows = crsTemp.RecordCount + 1
.TextMatrix(0, 0) = "FACTOR"
.TextMatrix(0, 1) = "SI"
.TextMatrix(0, 2) = "DF"
.TextMatrix(0, 3) = "V"
.TextMatrix(0, 4) = "F"
.TextMatrix(0, 5) = "@(%)"
If crsTemp.RecordCount > 0 Then
crsTemp.MoveLast
LastData = crsTemp.Fields(2).Value
crsTemp.MoveFirst
pDataValue = 0
For i = 1 To crsTemp.RecordCount
.TextMatrix(i, 0) = crsTemp.Fields(1).Value
.TextMatrix(i, 1) = crsTemp.Fields(2).Value
.TextMatrix(i, 2) = 1
.TextMatrix(i, 3) = crsTemp.Fields(2).Value
If LastData = 0 Then
.TextMatrix(i, 4) = "--"
.TextMatrix(i, 5) = "--"
Else
If i <> .Rows - 1 Then
.TextMatrix(i, 4) = cLaiFormat(crsTemp.Fields(2).Value / LastData, 3)
Else
.TextMatrix(i, 4) = "--"
End If
If i <> .Rows - 1 Then
.TextMatrix(i, 5) = cLaiFormat(100 * ((crsTemp.Fields(2).Value - LastData) / AllDataValue), 3)
pDataValue = pDataValue + cLaiFormat(100 * ((crsTemp.Fields(2).Value - LastData) / AllDataValue), 3)
Else
.TextMatrix(i, 5) = cLaiFormat((100 - pDataValue), 3)
End If
End If
crsTemp.MoveNext
Next i
End If
'資料置中
For k = 0 To .Cols - 1
.ColAlignmentFixed(k) = 4
Next k
Label5.Caption = "St = " & AllDataValue
Label6.Caption = "@t = " & pDataValue
End With
End Sub
Private Sub setResGrid() '合併出圖 ( 重新傳入 rsMerge, pDataValue )
rsMergeStd.Sort = "FacID"
With ResDG
.Columns(0).DataField = "FacName"
.Columns(1).DataField = "FacSI"
.Columns(2).DataField = "FacDF"
.Columns(3).DataField = "FacV"
.Columns(4).DataField = "FacF"
.Columns(5).DataField = "FacP"
Set .DataSource = rsMergeStd
End With
' With ResGrid
' crsTemp.Sort = "FacSI Desc"
' .Cols = 6
' .Rows = crsTemp.RecordCount + 1
' .TextMatrix(0, 0) = "FACTOR"
' .TextMatrix(0, 1) = "SI"
' .TextMatrix(0, 2) = "DF"
' .TextMatrix(0, 3) = "V"
' .TextMatrix(0, 4) = "F"
' .TextMatrix(0, 5) = "@(%)"
' If crsTemp.RecordCount > 0 Then
' crsTemp.MoveLast
' LastData = crsTemp.Fields(2).Value
' crsTemp.MoveFirst
' pDataValue = 0
' For i = 1 To crsTemp.RecordCount
' .TextMatrix(i, 0) = crsTemp.Fields(1).Value
' .TextMatrix(i, 1) = crsTemp.Fields(2).Value
' .TextMatrix(i, 2) = 1
' .TextMatrix(i, 3) = crsTemp.Fields(2).Value
' If i <> .Rows - 1 Then
' .TextMatrix(i, 4) = cLaiFormat(crsTemp.Fields(2).Value / LastData, 3)
' Else
' .TextMatrix(i, 4) = "--"
' End If
' If i <> .Rows - 1 Then
' .TextMatrix(i, 5) = cLaiFormat(100 * ((crsTemp.Fields(2).Value - LastData) / AllDataValue), 3)
' pDataValue = pDataValue + cLaiFormat(100 * ((crsTemp.Fields(2).Value - LastData) / AllDataValue), 3)
' Else
' .TextMatrix(i, 5) = cLaiFormat((100 - pDataValue), 3)
' End If
' crsTemp.MoveNext
' Next i
' End If
' '資料置中
' For k = 0 To .Cols - 1
' .ColAlignmentFixed(k) = 4
' Next k
Label7.Caption = "St = " & AllDataValue
Label8.Caption = "@t = " & pDataValue
' End With
End Sub
Private Sub Form_Resize()
'設定 Form 位置
Me.Top = (ODEMDIForm.ScaleHeight - Me.Height) / 2
Me.Left = (ODEMDIForm.ScaleWidth - Me.Width) / 2
End Sub