2017-2-28
14:25

root
root

[程序代码]VB ini_excel文件操作

'**********************************************************************
'               功能函数'
'**********************************************************************
'           创建文件夹----------------'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

文章如需转载请注明:转载自: 紫灵幽梦
« 上一篇 下一篇 »

相关文章:

vb读取access并且显示  (2017-5-11 9:18:27)

VB 获取CPU温度示例  (2017-5-8 10:35:11)

VB程序逆向反汇编常见的函数   (2017-5-8 10:32:0)

VB内嵌汇编的模块示例  (2017-5-8 10:24:4)

内存数据的读写(PC)   (2017-3-1 17:51:40)

用VB制作外挂   (2017-3-1 16:16:53)

发表留言: