funct.bas

电子皮带秤计量管理系统.完成电子皮带秤的自动计量工作,和销售管理系统配合使用更佳.

   Attribute VB_Name = "ModFunCtion"
'CODE Manger By BcodeXRose

Option Explicit

Dim TheNumber As Integer
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As Any, ByVal lsString As Any, ByVal lplFilename As String) As Long
Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPriviteProfileIntA" (ByVal lpApplicationname As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
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
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const SWP_NOMOVE = &H2 '不移动窗体
Public Const SWP_NOSIZE = &H1 '不改变窗体尺寸
Public Const Flag = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1 '窗体总在最前面
Public Const HWND_NOTOPMOST = -2 '窗体不在最前面
Public RecordIndex As Integer '文件记录号
Public Result As String '"ini文件返回数据"
Public Const Hao1 As Byte = &H55
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public gsMonthData  As Single
Public gsDAYData  As Single
Public gsClassData As Single
Public MonthData  As Single
Public DAYData  As Single
Public ClassData As Single
Public Weight As Single
Public WeightB As Single
Private Type SyStem_Param
    txtDayca As Integer
    ClassData As Single
    DAYData As Single
    MonthData As Single
End Type
Public SyStemData As SyStem_Param
'写.INI文件
'##################################################################
'## 过程名称：WriteINI
'## 参数：AppName 为String型
'## 参数：KeyName 为String型
'## 参数：MyValue 为String型
'## 参数：INIFileName 为String型
'##################################################################
Public Sub WriteINI(AppName As String, KeyName As String, MyValue As String, INIFileName As String)
    Dim lpAppName As String, lpFileName As String, lpKeyName As String, lpString As String
    Dim U As Long
    On Error Resume Next
    lpAppName = AppName
    lpKeyName = KeyName
    lpString = MyValue
    lpFileName = App.Path & INIFileName
    If lpString = "" Then lpString = "0"
    U = WritePrivateProfileString(lpAppName, lpKeyName, lpString, lpFileName)
    If U = 0 Then
        MsgBox ("读文件出错！")
    End If
End Sub
    
    '读.INI文件
'##################################################################
'## 过程名称：ReadINI
'## 参数：AppName 为String型
'## 参数：KeyName 为String型
'## 参数：INIFileName 为String型
'##################################################################
Public Sub ReadINI(AppName As String, KeyName As String, INIFileName As String)
    Dim X As Long
    Dim temp As String * 20
    Dim lpAppName As String, lpKeyName As String, lpDefault As String, lpFileName As String
    On Error Resume Next
    lpAppName = AppName
    lpKeyName = KeyName
    lpDefault = App.Path & INIFileName ' "\.INI"
    lpFileName = App.Path & INIFileName ' "\.INI"
    If Dir$(App.Path & INIFileName) = "" Then Result = "0": Exit Sub
    X = GetPrivateProfileString(lpAppName, lpKeyName, lpDefault, temp, Len(temp), lpFileName)
    Result = Trim(temp)
    
End Sub
    
    
    '*********************
    '*创建多级目录*
    '*********************
    
    'sDir= "\XX\XX\XX\..."
'##################################################################
'## 过程名称：CreateMyDir
'## 参数：sDir 为String型
'##################################################################
Sub CreateMyDir(sDir As String)
    Dim sBuild As String
    Dim sDrive As String
    On Error Resume Next
    sDrive = App.Path
    While InStr(2, sDir, "\") > 1
    sBuild = sBuild & Left(sDir, InStr(2, sDir, "\") - 1)
    sDir = Mid(sDir, InStr(2, sDir, "\"))
    If Dir(sDrive & sBuild, 16) = "" Then
        MkDir sDrive & sBuild
    End If
    Wend
End Sub
    
    '*******************************
    '*十六进制转换十进制*
    '*******************************
    
'##################################################################
'## 函数名称：HexToDec
'## 参数：TheString 为String型
'As Integer'## 返回类型：As Integer
'##################################################################
Function HexToDec(TheString As String) As Integer
    Dim iLen As String
    Dim iFlag As Integer
    Dim strTemp As Integer
    On Error Resume Next
    strTemp = 0
    iLen = Right(TheString, 2) & Left(TheString, 2)
    For iFlag = 1 To 4
        If Asc(Mid(iLen, iFlag, 1)) <= 57 And Asc(Mid(iLen, iFlag, 1)) >= 48 Then
            strTemp = strTemp + (Asc(Mid(iLen, iFlag, 1)) - 48) * (16 ^ (4 - iFlag))
        ElseIf Asc(Mid(iLen, iFlag, 1)) >= 65 And Asc(Mid(iLen, iFlag, 1)) <= 70 Then
            strTemp = strTemp + (Asc(Mid(iLen, iFlag, 1)) - 55) * (16 ^ (4 - iFlag))
        End If
    Next iFlag
    HexToDec = strTemp
End Function
    
'##################################################################
'## 过程名称：OnlyOne
'## 参数： 无
'##################################################################
Public Sub OnlyOne()
    If App.PrevInstance Then
        MsgBox "该应用程序已经有一个实例在运行，按“确定”退出！", _
        vbOKOnly Or vbCritical, "运行错误"
        End
    End If
End Sub
'##################################################################
'## 过程名称：SysLoad
'## 参数：ByVal 为e As Boolean型
'##################################################################
Sub SysLoad(ByVal Save As Boolean)
    Dim i As Integer
    Dim Filenum As Integer
    Dim filename As String
    
    filename = App.Path & "\SysData.bin"
    Filenum = FreeFile()
    Open filename For Binary As Filenum
    If Save Then
        gsClassData = ClassData
        gsDAYData = DAYData
        gsMonthData = MonthData
        Put #Filenum, , SyStemData
    Else
        If Save = False Then
            Get #Filenum, , SyStemData
            ClassData = gsClassData
            DAYData = gsDAYData
            MonthData = gsMonthData
        End If
    End If
    Close #Filenum
End Sub
    
    '****************************
    '*    延时DelayTime时间     *
    '****************************
    
'##################################################################
'## 过程名称：Delay
'## 参数：DelayTime 为Single型
'##################################################################
Public Sub Delay(DelayTime As Single)
    Dim MyTime
    MyTime = Timer
    Do
        DoEvents
        If Timer <= MyTime Then Exit Do
    Loop Until Timer >= MyTime + DelayTime
End Sub