VB ini_excel文件操作
0 Reply , Posted in 程序代码 on 2017 28, 2017
'**********************************************************************
' 功能函数'
'**********************************************************************
' 创建文件夹----------------'CreateDefaultFolder
' 删除文件夹----------------'DeleteFolder
' 创建 文件 ---------------'CreateDefaultFile
' 删除 文件 ---------------'DeleteFile
' 读取数据到对象------------'ReadDataToOBJ
' 获取极值----------------------'GetMostVlaue
' 保存数据到文件----------------'SaveDataToFile
' 读取文件到对象----------------'ReadDataToOBJ
' 保存数据到excel---------------'SaveDataToExcle
' 将本次试验写入记录-------------'WriteThisTest
' 读取上次试验记录---------------'ReadLasttest
' 获得文件夹路径-----------------'GetFolderPath
'**********************************************************************
Option Explicit
''''folder path
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Const BFFM_INITIALIZED As Long = 1
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Public Const MAX_PATH = 260
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Const LPTR = (&H0 Or &H40)
Public Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Public LastTestDate As String
Public LastTestMachin As String
Public LastTestMaterail As String
Public LastTestStyle As String
Public LastDataSavePath As String
'Public DefaultPath As String
Public Const LastTest = "LastTest"
''''''''''''''''''''''''''''''''''''''''''''''''''''
'***************************************************
Public OpenedFile(1 To 6) As String
Public SubmnuNull11(1 To 6) As String
Private Const pheaded = "OpenedFile"
Public Sub Init_SubmnuNull11()
SubmnuNull11(1) = "First"
SubmnuNull11(2) = "Second"
SubmnuNull11(3) = "Third"
SubmnuNull11(4) = "Forth"
SubmnuNull11(5) = "Fifth"
SubmnuNull11(6) = "Sixth"
End Sub
Public Function GetFolderPath(pfrm As Form) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
Dim Ret As Long
szTitle = "选择保存路径"
Dim sPath As String
'sPath = VBA.InputBox("初始路径:", , "C:\program files")
sPath = "C:\program files"
With tBrowseInfo
.hWndOwner = pfrm.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
.lpfnCallback = MyAddressOf(AddressOf BrowseForFolders_CallbackProc)
Ret = LocalAlloc(LPTR, VBA.Len(sPath) + 1)
CopyMemory ByVal Ret, ByVal sPath, VBA.Len(sPath) + 1
.lParam = Ret
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = VBA.Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = VBA.Left(sBuffer, VBA.InStr(sBuffer, vbNullChar) - 1)
GetFolderPath = sBuffer
End If
End Function
Public Function MyAddressOf(AddressOfX As Long) As Long
MyAddressOf = AddressOfX
End Function
Public Function BrowseForFolders_CallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSELECTIONA, True, ByVal lpData
End If
End Function
'********************************************
''''''''''''''''''''''''''''''''''''''''
Public Function WriteThisTest(ByVal pFileName As String)
Dim fso As New FileSystemObject
On Error GoTo ErrorHandle
If pFileName = vbNullString Then Exit Function
If Not fso.FileExists(pFileName) Then
fso.CreateTextFile (pFileName)
End If
LastTestDate = Date
LastTestMachin = "Reger-4010"
LastTestStyle = GetTestStyle(MyTestStyle)
LastTestMaterail = GetMaterialName(MyMaterialsStyle)
WritePrivateProfileString LastTest, "LastTestDate", LastTestDate, pFileName
WritePrivateProfileString LastTest, "LastTestMachin", LastTestMachin, pFileName
WritePrivateProfileString LastTest, "LastTestMaterail", LastTestMaterail, pFileName
WritePrivateProfileString LastTest, "LastTestStyle", LastTestStyle, pFileName
WritePrivateProfileString LastTest, "LastDataSavePath", LastDataSavePath, pFileName
' WritePrivateProfileString LastTest, "DefaultPath", DefaultPath, pFileName
Exit Function
ErrorHandle:
If MsgBox("WriteThisTest" & vbCrLf & Err.Description, vbInformation + vbOKOnly, "错误") = vbOK Then
Exit Function
End If
End Function
Public Function ReadLasttest(ByVal pFileName As String)
Dim LastTestDate As String, LastTestMachin As String
Dim LastTestMaterail As String, LastTestStyle As String
Dim LastDataSavePath As String, DefaultPath As String
Dim ReturnStr As String
Dim ReturnLng As Long
Dim ReadString As String
On Error GoTo ErrorHandle
If pFileName = vbNullString Then Exit Function
ReadString = vbNullString
ReturnStr = Space(200)
ReturnLng = GetPrivateProfileString(LastTest, "LastTestDate", vbNullString, ReturnStr, 200, pFileName)
LastTestDate = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString(LastTest, "LastTestMachin", vbNullString, ReturnStr, 200, pFileName)
LastTestMachin = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString(LastTest, "LastTestMaterail", vbNullString, ReturnStr, 200, pFileName)
LastTestMaterail = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString(LastTest, "LastTestStyle", vbNullString, ReturnStr, 200, pFileName)
LastTestStyle = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString(LastTest, "LastDataSavePath", vbNullString, ReturnStr, 200, pFileName)
LastDataSavePath = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString(LastTest, "DefaultPath", vbNullString, ReturnStr, 200, pFileName)
DefaultPath = Left(ReturnStr, ReturnLng)
Exit Function
ErrorHandle:
If MsgBox("ReadLasttest" & vbCrLf & Err.Description, vbInformation + vbOKOnly, "错误") = vbOK Then
Exit Function
End If
End Function
Public Function CreateDefaultFolder(ByVal pPathstr As String)
Dim fso As New FileSystemObject
Dim wanqu As String
Dim lashen As String
Dim yasuo As String
Dim jianqie As String
Dim boli As String
Dim silie As String
pPathstr = pPathstr & "\" & Date & "-TestData"
wanqu = pPathstr & "\弯曲"
lashen = pPathstr & "\拉伸"
yasuo = pPathstr & "\压缩"
jianqie = pPathstr & "\剪切"
boli = pPathstr & "\剥离"
silie = pPathstr & "\撕裂"
If Not fso.FolderExists(pPathstr) Then
fso.CreateFolder (pPathstr)
End If
If Not fso.FolderExists(wanqu) Then
fso.CreateFolder (wanqu)
End If
If Not fso.FolderExists(lashen) Then
fso.CreateFolder (lashen)
End If
If Not fso.FolderExists(yasuo) Then
fso.CreateFolder (yasuo)
End If
If Not fso.FolderExists(jianqie) Then
fso.CreateFolder (jianqie)
End If
If Not fso.FolderExists(boli) Then
fso.CreateFolder (boli)
End If
If Not fso.FolderExists(silie) Then
fso.CreateFolder (silie)
End If
End Function
Public Function DeleteFolder(ByVal pFolderName As String)
Dim fso As New FileSystemObject
If fso.FolderExists(pFolderName) Then
fso.DeleteFolder (pFolderName)
Else
MsgBox "文件夹不存在！", vbOKOnly, "警告"
End If
End Function
Public Function CreateDefaultFile(ByVal pFileName As String, ByVal pPathstr As String) As Boolean
Dim fso As New FileSystemObject
On Error GoTo ErrorHandle
Dim MyFilePath As String
If Not fso.FolderExists(pPathstr) Then MsgBox "路径出错！", vbInformation + vbOKOnly, "Error": Exit Function
MyFilePath = pPathstr & "\" & pFileName & Replace(Time, ":", "-", 1, -1) & ".txt"
If Not fso.FileExists(MyFilePath) Then
fso.CreateTextFile (MyFilePath)
CreateDefaultFile = True
End If
Exit Function
ErrorHandle:
If MsgBox("CreateDefaultFile" & vbCrLf & Err.Description, vbInformation + vbOKOnly, "错误") = vbOK Then
CreateDefaultFile = False
Exit Function
End If
End Function
Public Function DeleteFile(ByVal pFileName As String)
Dim fso As New FileSystemObject
If fso.FileExists(pFileName) Then
fso.DeleteFile (pFileName)
MsgBox pFileName & "删除文件成功", vbOKOnly, "警告"
Else
MsgBox "文件不存在！", vbOKOnly, "警告"
End If
End Function
Public Function SaveDataToFile(pDLG As CommonDialog, pClsDataS As RecieveDataS, _
pPath As String, _
pTestStyle As TestStyle)
Dim i As Single
Dim pRecieveData As RecieveData
On Error GoTo ErrorHandle
With pDLG
.FileName = ""
Select Case pTestStyle
Case Pull_UpTest
.Filter = "数据文件(*.PUT)|*.PUT|所有文件(*.*)|*.*"
Case CompressTest
.Filter = "数据文件(*.CPT)|*.CPT|所有文件(*.*)|*.*"
Case Turn_RoundTest
.Filter = "数据文件(*.TRT)|*.TRT|所有文件(*.*)|*.*"
Case TearTest
.Filter = "数据文件(*.TT)|*.TT|所有文件(*.*)|*.*"
Case PunctureTest
.Filter = "数据文件(*.PTT)|*.PTT|所有文件(*.*)|*.*"
Case Bursting_StrengthTest
.Filter = "数据文件(*.BST)|*.BST|所有文件(*.*)|*.*"
Case Default
.Filter = "文件类型(*.*)"
End Select
.DialogTitle = "保存文件"
.InitDir = pPath
.ShowSave
.Flags = cdlOFNOverwritePrompt
' SaveFile = CommonDialog1.FileName
If .FileName = "" Then Exit Function
On Error Resume Next
Open .FileName For Append As #2
'数据组，数据集
Write #2, pClsDataS.Count
For Each pRecieveData In pClsDataS
Write #2, pRecieveData.ForceData, _
pRecieveData.LengthData, _
pRecieveData.SpeedData, _
pRecieveData.Temperature, _
pRecieveData.TimeData
Next
Close #2
End With
Exit Function
ErrorHandle:
If MsgBox("SaveDataToFile" & vbCrLf & Err.Description, vbInformation + vbOKOnly, "错误") = vbOK Then
Exit Function
End If
End Function
Public Function ReadDataToOBJ(pDLG As CommonDialog, ByVal pTestStyle As TestStyle, ByVal pDefaultPath As String)
'获得行数，每一行数据有分类
Dim i As Single
Dim pFileName As String
Dim pCount As Integer
Dim pRecieveData As RecieveData
Dim pClsDataS As RecieveDataS
Dim tmpForcedata As Single, tmpLengthData As Single
Dim tmpSpeedData As Single, tmpTemperature As Single
Dim tmpTimeData As Single
On Error GoTo ErrorHandle
With pDLG
.FileName = ""
Select Case pTestStyle
Case Pull_UpTest
.Filter = "数据文件(*.PUT)|*.PUT|所有文件(*.*)|*.*"
Case CompressTest
.Filter = "数据文件(*.CPT)|*.CPT|所有文件(*.*)|*.*"
Case Turn_RoundTest
.Filter = "数据文件(*.TRT)|*.TRT|所有文件(*.*)|*.*"
Case TearTest
.Filter = "数据文件(*.TT)|*.TT|所有文件(*.*)|*.*"
Case PunctureTest
.Filter = "数据文件(*.PTT)|*.PTT|所有文件(*.*)|*.*"
Case Bursting_StrengthTest
.Filter = "数据文件(*.BST)|*.BST|所有文件(*.*)|*.*"
Case Default
.Filter = "所有文件(*.*)|*.*"
End Select
.DialogTitle = "读取文件"
.InitDir = pDefaultPath
.Flags = cdlOFNOverwritePrompt
.ShowOpen
pFileName = .FileName
If pFileName = "" Then
MsgBox "没有选择文件", vbInformation + vbOKOnly, "选择"
Exit Function
End If
'-----------------------用于显示打开过的文件
For i = 6 To 2 Step -1
OpenedFile(i) = OpenedFile(i - 1)
Next
OpenedFile(1) = pFileName
'-----------------------------------------
'read data to object and line in the picture
Dim DatasLines As Single
Set MyRecieveDataS = New RecieveDataS
Open pFileName For Input As #1
Input #1, DatasLines
For i = 1 To DatasLines
Set OMyRecieveData = New RecieveData
Input #1, tmpForcedata, tmpLengthData, tmpSpeedData, tmpTemperature, tmpTimeData
OMyRecieveData.ForceData = tmpForcedata
OMyRecieveData.LengthData = tmpLengthData
OMyRecieveData.SpeedData = tmpSpeedData
OMyRecieveData.Temperature = tmpTemperature
OMyRecieveData.TimeData = tmpTimeData
OMyRecieveData.Key = i
MyRecieveDataS.Add OMyRecieveData, OMyRecieveData.Key
Call Pic_DrawLine(FrmCurveShow.PicCurve, OMyRecieveData, Force_Lenght, SysVBRed)
Next
Close #1
Call SetSubmnuNullFileName(App.Path & "\LastTest.INI")
Exit Function
' Open pFileName For Input As #1
' '数据组，数据集
' Input #1, pCount, pNumClsDataS
' 'ReDim pClsDataS(pNumClsDataS)
' Do While (i <= pCount)
' Set pRecieveData = New RecieveData
' Input #1, tmpForcedata, tmpLengthData, tmpSpeedData, tmpTemperature, tmpTimeData
'
' pRecieveData.ForceData = tmpForcedata
' pRecieveData.LengthData = tmpLengthData
' pRecieveData.SpeedData = tmpSpeedData
' pRecieveData.Temperature = tmpTemperature
' pRecieveData.TimeData = tmpTimeData
' pClsDataS.Add pRecieveData, pRecieveData.Key
'
' Set pRecieveData = Nothing
' Loop
' Close #1
End With
Exit Function
ErrorHandle:
If MsgBox("ReadDataToOBJ" & vbCrLf & Err.Description, vbInformation + vbOKOnly, "错误") = vbOK Then
Exit Function
End If
End Function
Public Function SaveDataToExcle(pDLG As CommonDialog, pClsDataS As RecieveDataS, pCols As Integer, ByVal FileName As String)
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim i As Integer, pCol As Integer
Dim pRecieveData As ClsShowResult
On Error GoTo ErrorHandle
Set xlApp = Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
'''设置格式
xlApp.ActiveSheet.Rows.VerticalAlignment = xlVAlignCenter '''''垂直方向居中
xlApp.ActiveSheet.Rows.HorizontalAlignment = xlVAlignCenter '''水平方向居中
xlSheet.name = "测试结果"
With xlSheet
.Range("A1", "H22").Borders.LineStyle = xlContinuous '''''''''''单元格边框
.Range("A1", "H22").Borders.Color = vbBlue ''''''''''''''''''''''边框颜色
.Range("A1", "H22").Interior.Color = RGB(100, 180, 0) '''''''''''区域 背景色
'第一行-----------------------------------------------------
For i = 1 To 8
.Range(Cells(1, 1), Cells(1, i)).Merge
Next
.Cells(1, 1).Font.Size = 30
.Columns(1).ColumnWidth = 25
.Range("A1").value = "剥离试验报告"
'第二行-----------------------------------------------------
For i = 1 To 3
.Range(Cells(2, 1), Cells(2, i)).Merge
Next
.Range("A2").value = "试验部门(单位)："
For i = 4 To 7
.Range(Cells(2, 1), Cells(2, i)).Merge
Next
.Range("A2").value = "深圳瑞格尔仪器"
'第三行-----------------------------------------------------
.Range("A3").value = "材料名称："
.Range(Cells(3, 2), Cells(3, 3)).Merge
.Range("D3").value = "试样形状："
.Range(Cells(3, 5), Cells(3, 6)).Merge
.Range("G3").value = "湿度："
'B3\E3\H3---材料名称\试样形状\湿度
'第四行-----------------------------------------------------
.Range("A4").value = "试验标准："
.Range(Cells(4, 2), Cells(4, 3)).Merge
.Range("D4").value = "温度："
.Range(Cells(4, 5), Cells(4, 6)).Merge
.Range("G4").value = "速度："
'B4\E4\H4---试验标准\温度\速度
'第五行-----------------------------------------------------
.Range("A5").value = "试样批号"
.Range("B5").value = "最大载荷"
.Range("C5").value = "最大峰值"
.Range("D5").value = "最小峰值"
.Range("E5").value = "平均峰值"
.Range("F5").value = "极 差"
.Range("G5").value = "剥离强度"
.Range("H5").value = "平均强度"
'第六行-----------------------------------------------------
.Range("B5").value = "N"
.Range("C5").value = "N"
.Range("D5").value = "N"
.Range("E5").value = "N"
.Range("F5").value = "N"
.Range("G5").value = "N/m"
.Range("H5").value = "N/m"
'遍历实验数据的极值-----------------------------------------------------
pCol = 6
On Error Resume Next
For Each pRecieveData In pClsDataS
.Range("B" & pCol).value = pRecieveData.MaxForceData
.Range("C" & pCol).value = pRecieveData.MaxLengthData
.Range("D" & pCol).value = pRecieveData.MaxSpeedData
.Range("E" & pCol).value = pRecieveData.MaxTemperature
.Range("F" & pCol).value = pRecieveData.MaxTimeData
.Range("G" & pCol).value = pRecieveData.AverageForceData
.Range("H" & pCol).value = pRecieveData.AverageLengthData
.Range("I" & pCol).value = pRecieveData.AverageSpeedData
.Range("J" & pCol).value = pRecieveData.AverageTemperature
.Range("K" & pCol).value = pRecieveData.AverageTimeData
pCol = pCol + 1
Next
'第六+pCol行-----------------------------------------------------
' .Range("B" & pCol).Value = Max()
' .Range("B" & pCol).Value
' .Range("B" & pCol).Value
'-----------------------------------------------------
'-----------------------------------------------------
'-----------------------------------------------------
'-----------------------------------------------------
'-----------------------------------------------------
End With
xlApp.ActiveWorkbook.SaveAs App.Path & "\" & FileName + ".xls"
xlApp.Workbooks.Close
xlApp.Quit
Set xlApp = Nothing '释放引用
Exit Function
ErrorHandle:
If MsgBox("SaveDataToExcle" & vbCrLf & Err.Description, vbInformation + vbOKOnly, "错误") = vbOK Then
xlApp.Workbooks.Close
xlApp.Quit
Set xlApp = Nothing '释放引用
Exit Function
End If
End Function
Public Sub SetSubmnuNullFileName(pfile As String)
Dim fso As New FileSystemObject
Dim i As Integer
If Not fso.FileExists(pfile) Then fso.CreateTextFile (pfile)
For i = 1 To 6
WritePrivateProfileString pheaded, SubmnuNull11(i), OpenedFile(i), pfile
Next
End Sub
Public Sub GetSubmnuNullFileName(pfrm As FrmMain, ByVal pfile As String)
Dim fso As New FileSystemObject
Dim i As Integer
Dim ReturnStr As String
Dim ReturnLng As Long
Dim ReadString As String
If Not fso.FileExists(pfile) Then
MsgBox "文件不存在!"
pfrm.mnuNull11(0).Visible = False
For i = 1 To 6
OpenedFile(i) = ""
Next
Exit Sub
End If
For i = 1 To 6
ReadString = vbNullString
ReturnStr = Space(200)
ReturnLng = GetPrivateProfileString(pheaded, SubmnuNull11(i), vbNullString, ReturnStr, 200, pfile)
OpenedFile(i) = Left(ReturnStr, ReturnLng)
If OpenedFile(i) <> "" Then
Load pfrm.mnuNull11(i)
pfrm.mnuNull11(i).Caption = OpenedFile(i)
pfrm.mnuNull11(i).Visible = True
End If
Next
End Sub
Public Sub GetDefaultParamer(ByVal pfile As String)
Dim fso As New FileSystemObject
Dim i As Integer
Dim ReturnStr As String
Dim ReturnLng As Long
Dim ReadString As String
If Not fso.FileExists(pfile) Then
MsgBox "文件不存在!"
Exit Sub
End If
ReadString = vbNullString
ReturnStr = Space(200)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultMaterial", vbNullString, ReturnStr, 200, pfile)
DefaultMaterial = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultMateStyle", vbNullString, ReturnStr, 200, pfile)
DefaultMateStyle = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultMaxSpeed", vbNullString, ReturnStr, 200, pfile)
DefaultMaxSpeed = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultCheckPoint", vbNullString, ReturnStr, 200, pfile)
DefaultCheckPoint = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultJudgePoint", vbNullString, ReturnStr, 200, pfile)
DefaultJudgePoint = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultForceOver", vbNullString, ReturnStr, 200, pfile)
DefaultForceOver = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultStrengthOver", vbNullString, ReturnStr, 200, pfile)
DefaultStrengthOver = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultLengthOver", vbNullString, ReturnStr, 200, pfile)
DefaultLengthOver = Left(ReturnStr, ReturnLng)
ReturnLng = GetPrivateProfileString("DefaultParamer", "DefaultTemperOver", vbNullString, ReturnStr, 200, pfile)
DefaultTemperOver = Left(ReturnStr, ReturnLng)
End Sub
Public Function SetDefaultParamer(ByVal pfile As String)
Dim fso As New FileSystemObject
If pfile = vbNullString Then Exit Function
If Not fso.FileExists(pfile) Then
fso.CreateTextFile (pfile)
End If
WritePrivateProfileString "DefaultParamer", "DefaultMaterial", DefaultMaterial, pfile
WritePrivateProfileString "DefaultParamer", "DefaultMateStyle", DefaultMateStyle, pfile
WritePrivateProfileString "DefaultParamer", "DefaultMaxSpeed", DefaultMaxSpeed, pfile
WritePrivateProfileString "DefaultParamer", "DefaultCheckPoint", DefaultCheckPoint, pfile
WritePrivateProfileString "DefaultParamer", "DefaultJudgePoint", DefaultJudgePoint, pfile
WritePrivateProfileString "DefaultParamer", "DefaultForceOver", DefaultForceOver, pfile
WritePrivateProfileString "DefaultParamer", "DefaultStrengthOver", DefaultStrengthOver, pfile
WritePrivateProfileString "DefaultParamer", "DefaultLengthOver", DefaultLengthOver, pfile
WritePrivateProfileString "DefaultParamer", "DefaultTemperOver", DefaultTemperOver, pfile
End Function
