common.bas

对于符合国际标准COMTRADE格式的数据进行转换处理

Attribute VB_Name = "common"
Option Explicit

Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWDEFAULT = 10

' API call to execute commands with the windows shell
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
 
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 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

Global Const SWP_NOMOVE = &H2
Global Const SWP_NOSIZE = &H1

Global Const HWND_TOPMOST = -1
Global Const SWP_SHOWWINDOW = &H40
Global Const SWP_NOACTIVATE = &H10

' 防止运行多个例程
Global Const cnEndNewInstance = 0 ' 结束新的例程

' blGetFileName: TRUE--取文件名, FALSE--取路径
Public Function sFullNameSplit(sFullName As String, blGetFileName As Boolean)  ' 文件名
    On Error Resume Next
    
    Dim strLen As Byte
    Dim i As Integer
    
    Dim filename As String, PathName As String
    
    ' 去除空格
    sFullName = Trim$(sFullName)
    
    filename = ""
    PathName = ""
    
    strLen = Len(sFullName)
    
    ' 从字符串尾开始寻找 "\", 之前为路径,之后为文件名
    For i = strLen To 1 Step -1
        If Mid$(sFullName, i, 1) = "\" Then
            Exit For
        End If
        
        filename = Mid$(sFullName, i, 1) + filename
    Next i
        
    ' 截取路径
    If i >= 1 Then
        PathName = Mid$(sFullName, 1, i - 1)
    Else
        PathName = ""
        filename = sFullName
    End If
    
    If blGetFileName Then
        sFullNameSplit = filename ' 取文件名
    Else
        sFullNameSplit = PathName ' 取路径
    End If
End Function

' blGetExt: TRUE--取扩展名, FALSE--取文件名
Public Function sGetExtOrNameOfFile(sFullName As String, blGetExt As Boolean) As String
    On Error Resume Next
    
    Dim strLen As Byte
    Dim i As Integer
    
    Dim filename As String, extname As String
    
    ' 去除空格
    sFullName = Trim$(sFullName)
    
    filename = ""
    extname = ""
    
    strLen = Len(sFullName)
    
    ' 从字符串尾开始寻找 ".", 之前为文件名,之后为扩展名
    For i = strLen To 1 Step -1
        If Mid$(sFullName, i, 1) = "." Then
            Exit For
        End If
        
        extname = Mid$(sFullName, i, 1) + extname
    Next i
        
    ' 截取文件名
    If i >= 1 Then
        filename = Mid$(sFullName, 1, i - 1)
    Else
        extname = ""
        filename = sFullName
    End If
    
    If blGetExt Then
        sGetExtOrNameOfFile = extname  ' 取扩展名
    Else
        sGetExtOrNameOfFile = filename ' 取文件名
    End If
End Function

' 按给定宽度在sStr字符串中填充空格,即不足长度出补空格, 返回空格字符串
Function sFillSpace(sStr As String, iWidth As Integer) As String
    If Len(sStr) >= iWidth Then
        sFillSpace = ""  ' 已够长
    Else
        sFillSpace = Space(iWidth - Len(sStr))
    End If
End Function

' 按给定长度格式化, 前缀空格
Function FormatWithLeftSpace(vExpression As Variant, sFormatStr As String, iWidth As Integer) As String
    Dim str1 As String
    
    str1 = Format(vExpression, sFormatStr)
    FormatWithLeftSpace = sFillSpace(str1, iWidth) + str1
End Function

' 按给定长度格式化, 后缀空格
Function FormatWithRightSpace(vExpression As Variant, sFormatStr As String, iWidth As Integer) As String
    Dim str1 As String
    
    str1 = Format(vExpression, sFormatStr)
    str1 = str1 + sFillSpace(str1, iWidth)
End Function

' 将 INTEGER1 和 INTEGER2 合并为 double (无符号数)
Function MergeIntegerToDouble(INTEGER1 As Integer, INTEGER2 As Integer) As Double
    On Error Resume Next
    
    MergeIntegerToDouble = Val("&H" + ConvertIntegerToHex(INTEGER2, 2) + ConvertIntegerToHex(INTEGER1, 2))
    
    If MergeIntegerToDouble < 0 Then
        If INTEGER2 Then ' 高字不为零
            MergeIntegerToDouble = 65536# * 65536# + MergeIntegerToDouble
        Else ' 高字为零
            MergeIntegerToDouble = 65536# + MergeIntegerToDouble
        End If
    End If
End Function


' 将 INTEGER1 和 INTEGER2 合并为 Long
Function MergeIntegerToLong(INTEGER1 As Integer, INTEGER2 As Integer) As Long
    On Error Resume Next
    
    Dim tempLong As Long
    Dim tempDouble As Double
    
    MergeIntegerToLong = Val("&H" + ConvertIntegerToHex(INTEGER2, 2) + ConvertIntegerToHex(INTEGER1, 2))
End Function

' 将 byte1 和 byte2 合并为 Integer
Function Merge2BytesToLong(BYTE1 As Byte, BYTE2 As Byte) As Long
    On Error Resume Next
    
    Dim byte1Lng  As Long, byte2Lng As Long
    
    byte1Lng = BYTE1: byte2Lng = BYTE2
    
    Merge2BytesToLong = byte2Lng * 256 + byte1Lng
End Function

' 将 byte1 和 byte2 合并为 Integer
Function Merge2BytesTointeger(BYTE1 As Byte, BYTE2 As Byte) As Integer
    If BYTE2 > &H7F Then
        Merge2BytesTointeger = Val("&H" + ConvertByteToHex(BYTE2) + ConvertByteToHex(BYTE1))
    Else
        Merge2BytesTointeger = BYTE2
        Merge2BytesTointeger = Merge2BytesTointeger * (2 ^ 8) + BYTE1
    End If
End Function

' 将 byte1 - byte4 合并为 long
Function Merge4BytesToLong(BYTE1 As Byte, BYTE2 As Byte, BYTE3 As Byte, BYTE4 As Byte) As Long
    If BYTE4 > &H7F Then
        Merge4BytesToLong = Val("&H" + ConvertByteToHex(BYTE4) + ConvertByteToHex(BYTE3) + ConvertByteToHex(BYTE2) + ConvertByteToHex(BYTE1))
    Else
        Merge4BytesToLong = BYTE4
        Merge4BytesToLong = Merge4BytesToLong * (2 ^ 8) + BYTE3
        Merge4BytesToLong = Merge4BytesToLong * (2 ^ 8) + BYTE2
        Merge4BytesToLong = Merge4BytesToLong * (2 ^ 8) + BYTE1
    End If
End Function

' 将BYTE型转换成16进制显示的字符串
Function ConvertByteToHex(code As Byte) As String
    On Error Resume Next
    
    ConvertByteToHex = Hex$(code)
    
    If (Len(ConvertByteToHex) < 2) Then
        ConvertByteToHex = "0" + ConvertByteToHex
    End If
End Function

' 将整型转换为 HEX 格式显示
' ---------------------------
' value 用于转换的值
' BytesValid 有效的字节数
Function ConvertIntegerToHex(value As Integer, BytesValid As Byte) As String
    On Error Resume Next
    
    Dim zeroStr As String, F_Str As String
    
    zeroStr = "0000000000"
    F_Str = "FFFFFFFFFF"
    
    ConvertIntegerToHex = Hex$(value)
    
    If (Len(ConvertIntegerToHex) < 2 * BytesValid) Then
        If value < 0 Then
            ConvertIntegerToHex = MidB(F_Str, 1, 2 * BytesValid - Len(ConvertIntegerToHex)) + ConvertIntegerToHex
        Else
            ConvertIntegerToHex = MidB(zeroStr, 1, 2 * BytesValid - Len(ConvertIntegerToHex)) + ConvertIntegerToHex
        End If
    ElseIf (Len(ConvertIntegerToHex) > 2 * BytesValid) Then
        ConvertIntegerToHex = MidB(ConvertIntegerToHex, Len(ConvertIntegerToHex) - 2 * BytesValid + 1, 2 * BytesValid)
    End If
End Function

' 将长整型转换为 HEX 格式显示
' ---------------------------
' value 用于转换的值
' BytesValid 有效的字节数
Function ConvertLongToHex(value As Long, BytesValid As Byte) As String
    On Error Resume Next
    
    Dim zeroStr As String, F_Str As String
    
    zeroStr = "0000000000"
    F_Str = "FFFFFFFFFF"
    
    ConvertLongToHex = Hex$(value)
    
    If (Len(ConvertLongToHex) < 2 * BytesValid) Then
        If value < 0 Then
            ConvertLongToHex = MidB(F_Str, 1, 2 * BytesValid - Len(ConvertLongToHex)) + ConvertLongToHex
        Else
            ConvertLongToHex = MidB(zeroStr, 1, 2 * BytesValid - Len(ConvertLongToHex)) + ConvertLongToHex
        End If
    ElseIf (Len(ConvertLongToHex) > 2 * BytesValid) Then
        ConvertLongToHex = MidB(ConvertLongToHex, Len(ConvertLongToHex) - 2 * BytesValid + 1, 2 * BytesValid)
    End If
End Function

' 检查是否已有例程在运行
Public Function VariInstanceControl(tFormCaption As String, intAction As Integer, FormStatus As Integer) As Boolean
    On Error Resume Next
    
    Dim hWndOther As Long

    ' 检查是否有相同的窗口标题
    hWndOther = FindWindow(vbNullString, tFormCaption)
    VariInstanceControl = IIf(hWndOther = 0, False, True)
    If VariInstanceControl Then
        MsgBox "对不起，{" + csProgramTitle + "}的另外一个例程已经运行。", vbInformation + vbOKOnly, "非常感谢您使用本程序"
            
        AppActivate tFormCaption ' 使其拥有当前光标
        
        Call ShowWindow(hWndOther, FormStatus) ' 恢复窗口
        
        SetForegroundWindow hWndOther ' 将窗口推至前台

        If intAction = cnEndNewInstance Then  ' 调用成功，结束本程序
            End ' 结束本程序
        End If
    End If
End Function