mbase.bas

远端荧幕传输程序,远端荧幕传输程序.rar

End Type
Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Public Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(32) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(32) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type


'The following functions are used with system time.
Public Declare Sub GetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME)
Public Declare Function GetSystemTimeAdjustment Lib "kernel32.dll" (lpTimeAdjustment As Long, lpTimeIncrement As Long, lpTimeAdjustmentDisabled As Boolean) As Long
Public Declare Function LocalFileTimeToFileTime Lib "kernel32.dll" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Public Declare Function SetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME) As Long
Public Declare Function SetSystemTimeAdjustment Lib "kernel32.dll" (ByVal dwTimeAdjustment As Long, ByVal bTimeAdjustmentDisabled As Boolean) As Long
Public Declare Function SystemTimeToFileTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
Public Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32.dll" (lpTimeZoneInformation As TIME_ZONE_INFORMATION, lpUniversalTime As SYSTEMTIME, lpLocalTime As SYSTEMTIME) As Long


'The following functions are used with local time.
Public Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Public Declare Sub GetLocalTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME)
Public Declare Function GetTimeZoneInformation Lib "kernel32.dll" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Public Declare Function SetLocalTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME) As Long
Public Declare Function SetTimeZoneInformation Lib "kernel32.dll" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long


'The following functions are used with file time.
Public Declare Function CompareFileTime Lib "kernel32.dll" (lpFileTime1 As FILETIME, lpFileTime2 As FILETIME) As Long
Public Declare Function FileTimeToSystemTime Lib "kernel32.dll" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Public Declare Function GetFileTime Lib "kernel32.dll" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Public Declare Sub GetSystemTimeAsFileTime Lib "kernel32.dll" (ByRef lpSystemTimeAsFileTime As FILETIME)
Public Declare Function SetFileTime Lib "kernel32.dll" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long


'The following functions are used with MS-DOS date and time.
Public Declare Function DosDateTimeToFileTime Lib "kernel32.dll" (ByVal wFatDate As Long, ByVal wFatTime As Long, lpFileTime As FILETIME) As Long
Public Declare Function FileTimeToDosDateTime Lib "kernel32.dll" (lpFileTime As FILETIME, ByVal lpFatDate As Long, ByVal lpFatTime As Long) As Long


'The following functions are used with Windows time.
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long


'Timer(计时器)
Public Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
'VOID CALLBACK TimerProc(
'  HWND hwnd,         // handle to window
'  UINT uMsg,         // WM_TIMER message
'  UINT_PTR idEvent,  // timer identifier
'  DWORD dwTime       // current system time
');
'Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)



'//////////////////////////////////////////////////////////
'## VBLine ################################################
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Public Const VBLine_StepStart = &H1 '起始坐标是相对坐标
Public Const VBLine_UseColor = &H2 '使用Color参数
Public Const VBLine_UseStart = &H4 '使用起始坐标
Public Const VBLine_StepEnd = &H8 '结束坐标是相对坐标
Public Const VBLine_B = &H10 '线框
Public Const VBLine_BF = &H20 '填充举行

Public Const VBLine_FillRectAll = VBLine_UseColor Or VBLine_UseStart Or VBLine_BF




'///////////////////////////////////////////////////////////
'###########################################################
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Private m_Frequency As Currency

Private m_IsBusy As Long
Private m_OldTime As Currency
Private m_BusyTime As Currency

Public Function MyAddressOf(ByVal FunPtr As Long)
    MyAddressOf = FunPtr
End Function

Public Function VbColor2RGB(ByVal Color As OLE_COLOR, Optional hPalette As Long) As Long
    Dim t As Long
    If OleTranslateColor(Color, hPalette, t) = 0 Then
        VbColor2RGB = t
    Else
        VbColor2RGB = ErrIdx
    End If
End Function

'单位：毫秒
Public Function GetCurTime() As Currency
    If m_Frequency = 0 Then '未初始化
        If QueryPerformanceFrequency(m_Frequency) = 0 Then
            m_Frequency = ErrIdx '无高精度计数器
        End If
    End If
    
    If m_Frequency <> ErrIdx Then
        Dim CurCount As Currency
        Call QueryPerformanceCounter(CurCount)
        GetCurTime = CurCount * 1000@ / m_Frequency
        'Debug.Print GetCurTime
    Else
        GetCurTime = GetTickCount()
    End If
    
End Function

Public Function StartBusy() As Currency
    If m_IsBusy = 0 Then
        m_OldTime = GetCurTime()
        m_BusyTime = 0
        Screen.MousePointer = vbHourglass
    End If
    m_IsBusy = m_IsBusy + 1
    StartBusy = m_OldTime
End Function

Public Function EndBusy() As Currency
    If m_IsBusy > 0 Then
        m_IsBusy = m_IsBusy - 1
        If m_IsBusy = 0 Then
            m_BusyTime = GetCurTime() - m_OldTime
            Screen.MousePointer = vbDefault
        End If
    End If
    EndBusy = m_BusyTime
End Function

Public Property Get BusyTime() As Currency
    BusyTime = m_BusyTime
End Property
Public Function Hex2(ByVal Value As Byte) As String
    Hex2 = Right("0" & Hex(Value), 2)
End Function

Public Function Hex4(ByVal Value As Integer) As String
    Hex4 = Right(String(3, "0") & Hex(Value), 4)
End Function

Public Function Hex8(ByVal Value As Long) As String
    Hex8 = Right(String(7, "0") & Hex(Value), 8)
End Function


'## 模拟指针 ##############################################

'功能：构造模拟指针
'参数：
'pArray:数组的SafeArray结构的地址（VarPtrArray(数组名)的返回值）。必须是空的动态数组
'SA:某个SAFEARRAY1D，用于保存模拟指针描述
'ItemSize:数组元素的长度（所占字节，如Byte型为1），允许元素大小与步长不同
'lLbound:数组的下界
'cElements:数组的项目数（上界 = 下界 + 项目数 - 1）
'返回值：是否成功
Public Function MakePoint(ByVal pArray As Long, _
        ByRef SA As SAFEARRAY1D, ByVal ItemSize As Long, _
        Optional ByVal lLbound As Long = 0, _
        Optional ByVal cElements As Long = &H7FFFFFFF) As Boolean
    If pArray = 0 Then Exit Function
    
    With SA
        .cDims = 1
        .fFeatures = 0
        .cbElements = ItemSize
        .cLocks = 0
        .pvData = 0
        .Bounds(0).lLbound = lLbound
        .Bounds(0).cElements = cElements
    End With
    CopyMemory ByVal pArray, VarPtr(SA), 4
    
    MakePoint = True
    
End Function

'功能：释放模拟指针
'参数：
'pArray:数组的SafeArray结构的地址（VarPtrArray(数组名)的返回值）
'返回值：是否成功
Public Function FreePoint(ByVal pArray As Long) As Boolean
    If pArray = 0 Then Exit Function
    
    CopyMemory ByVal pArray, 0&, 4
    
    FreePoint = True
    
End Function

'设置模拟指针的地址
'参数：
'SA：某个模拟指针的SafeArray结构
Public Property Get Ptr(ByRef SA As SAFEARRAY1D) As Long
    Ptr = SA.pvData - SA.Bounds(0).lLbound * SA.cbElements
End Property
Public Property Let Ptr(ByRef SA As SAFEARRAY1D, ByVal RHS As Long)
    SA.pvData = RHS + SA.Bounds(0).lLbound * SA.cbElements
End Property


'## File ##################################################

Public Function ChkFileRead(FileName As String) As Boolean
    Dim hF As Integer
    hF = FreeFile(1)
    On Error Resume Next
    Open FileName For Input Access Read Lock Write As hF
    If Err.Number Then
        ChkFileRead = False
    Else
        Close hF
        ChkFileRead = True
    End If
End Function

Public Function ChkFileWrite(FileName As String) As Boolean
    Dim hF As Integer
    hF = FreeFile(1)
    On Error Resume Next
    Open FileName For Output As hF
    If Err.Number Then
        ChkFileWrite = False
    Else
        Close hF
        ChkFileWrite = True
    End If
End Function