utility.bas

AD9954源码

        'Draw the line along the right of the control
        ParentCtrl.Line (.Left + .Width + PX1, .Top)-(.Left + .Width + PX1, .Top + .Height)
    End With
End Sub

'Inserts a character every N'th character counted
'str   - Input string
'sChar - Character to Insert
'N     - Number of input string characters between character inserts
Function InsertChars(ByVal Str As String, ByVal sChar As String, ByVal N As Integer)
    Dim cntr As Integer
    Dim sCharCntr As Integer
    Dim sOutString As String
    
    sCharCntr = 1
    For cntr = 1 To Len(Str)
        sOutString = sOutString & Mid(Str, cntr, 1)
        If sCharCntr = N Then
            sOutString = sOutString & sChar
            sCharCntr = 1
        Else
            sCharCntr = sCharCntr + 1
        End If
    Next cntr
    'Return the output string
    InsertChars = sOutString
End Function

'Public Sub Delay()
'    Dim cntr As Double
'    Dim TimeStart As Single
'
'    'Initialize the counter
'    cntr = 0
'    'Get the number of seconds elapsed since midnight
'    TimeStart = Timer
'    Do
'        DoEvents
'    Loop While Timer() < TimeStart + 0.5
'
'End Sub

'Delays program execution by the DelayTime
'Input:  DelayTime - Time to delay in Seconds (1ms Resolution in WinNT, 55ms Resolution in Win95)
Public Sub Delay(ByVal DelayTime As Single, Optional NoDoEvents)
    Dim Start As Single
    Dim OldTimerVal As Single
    Dim EndTime As Single
    Dim DelayCntr As Long 'used to make sure that
    
    Start = Timer       'Set start time.
    OldTimerVal = Start 'Set the current timer val
    'Calculate the end time
    EndTime = Start + DelayTime
    
    'Setup the delay cntr
    DelayCntr = 0
    
    Do
        'Check for midnight
        If Timer < OldTimerVal Then
            EndTime = EndTime - OldTimerVal
            DelayCntr = 1000 'It is past midnight so refresh the OldTimerVal
        End If
        
        If DelayCntr >= 1000 Then
            OldTimerVal = Timer 'Get the current timer value
            DelayCntr = 0 'Reset the counter
        End If
           
        'Increment the delay counter
        DelayCntr = DelayCntr + 1
        
        'If the user enters any value for nodoevents
        If IsMissing(NoDoEvents) Then
            DoEvents   ' Yield to other processes.
        Else
        End If
    Loop While Timer < EndTime
End Sub

'Checks to see if a form is loaded using the forms collection
Public Function IsLoaded(FormName As String) As Boolean
    Dim cntr As Integer
    For cntr = 0 To Forms.Count - 1
        If (Forms(cntr).Name = FormName) Then
            IsLoaded = True
            Exit For
        End If
    Next
End Function

Public Sub DisableMinimizeButton(lhWnd As Long)
    Dim hSystemMenu As Long
    hSystemMenu = GetSystemMenu(lhWnd, 0)
    Call RemoveMenu(hSystemMenu, 3, MF_BYPOSITION)
End Sub

'Attempts to make a mdichild form modal for the program
Public Sub MakeMDIModal(frmMForm As Form, ByVal bEnable As Boolean)
    Dim cntr As Integer
    bEnable = Not bEnable
    'Start the counter at 2 because Forms(1) is the main mdi form
    For cntr = 2 To Forms.Count - 1
        'Disable all forms but the MainMDI and the Child to be Modalized
        If Forms(cntr).hWnd <> frmMForm.hWnd Then
            If bEnable = False Then
                Forms(cntr).Tag = Forms(cntr).Tag & CStr(Forms(cntr).Enabled)
            End If
            Forms(cntr).Enabled = bEnable
            If bEnable = True Then
                Forms(cntr).Tag = Left(Forms(cntr).Tag, Len(Forms(cntr).Tag) - 4)
            End If
        End If
    Next cntr
End Sub
'Extracts the filename out of a path
Public Function GetFileName(ByVal sPath As String) As String
    Dim CurStrLoc As Integer
    Dim LastLoc
    
    CurStrLoc = InStr(1, sPath, "\")
    Do
        LastLoc = CurStrLoc
        CurStrLoc = InStr(CurStrLoc + 1, sPath, "\")
    Loop While CurStrLoc <> 0
    
    GetFileName = Mid(sPath, LastLoc + 1, Len(sPath) - LastLoc + 1)
End Function

'Changes the priority of a process
Sub ChangePriority(dwPriorityClass As Long)
    Dim hProcess&
    Dim Ret&, pid&
    pid = GetCurrentProcessId() ' get my proccess id
    ' get a handle to the process
    hProcess = OpenProcess(PROCESS_DUP_HANDLE, True, pid)


    If hProcess = 0 Then
        Err.Raise 2, "ChangePriority", "Unable To open the source process"
        Exit Sub
    End If
    ' change the priority
    Ret = SetPriorityClass(hProcess, dwPriorityClass)
    ' Close the source process handle
    Call CloseHandle(hProcess)


    If Ret = 0 Then
        Err.Raise 4, "ChangePriority", "Unable To close source handle"
        Exit Sub
    End If
End Sub

'Locks a control so it wont be redrawn until unlocked
Public Function LockControl(objX As Object, cLock As Boolean)

   Dim i As Long
   
   If cLock Then
      ' Enable the Redraw flag for the specified window, and repaint
      Call SendMessage(objX.hWnd, WM_SETREDRAW, True, 0)
      objX.Refresh
   Else
      ' Disable the Redraw flag for the specified window
      Call SendMessage(objX.hWnd, WM_SETREDRAW, False, 0)
   End If

End Function

'Returns true if the passed control is an control array
'Returns false if the passed control is an control array
Public Function IsControlArray(ByVal ctrl As Control) As Boolean
    Dim value As Integer
    
    On Error GoTo ErrorHandler
    
    value = ctrl.Index
    
    IsControlArray = True
    
    Exit Function
ErrorHandler:
    'Err.Number
    Select Case Err.Number
        Case 343:
            IsControlArray = False
    End Select
End Function

'Returns true if the passed control has the container property
'Returns false if the passed control has the continer property
Public Function HasContainerProp(ByVal ctrl As Control) As Boolean
    Dim value As Integer
    
    On Error GoTo ErrorHandler
    
    value = ctrl.Container
    
    HasContainerProp = True
    
    Exit Function
ErrorHandler:
    'Err.Number
    Select Case Err.Number
        Case 343:
            HasContainerProp = False
    End Select
End Function

Public Sub EnableFrame(inFrame As Frame, ByVal Enble As Boolean)
    Dim CtrlCntr As Integer
    Dim IndxCntr As Integer
    
    For CtrlCntr = 0 To inFrame.Parent.Controls.Count - 1
        'If inframe is a control array make sure to only disable
        'the controls in the proper control array element
        If IsControlArray(inFrame) Then
            If inFrame.Parent.Controls(CtrlCntr).Name <> "ImageList1" Then
                If TypeOf inFrame.Parent.Controls(CtrlCntr).Container Is Frame Then
                    If IsControlArray(inFrame.Parent.Controls(CtrlCntr).Container) Then
                        If inFrame.Parent.Controls(CtrlCntr).Container.Index = inFrame.Index And _
                           inFrame.Parent.Controls(CtrlCntr).Container.Name = inFrame.Name Then
                            inFrame.Parent.Controls(CtrlCntr).Enabled = Enble
                        End If
                    End If
                End If
            End If
'        Else
'            If inFrame.Parent.Controls(CtrlCntr).Container.Name = inFrame.Name Then
'                inFrame.Parent.Controls(CtrlCntr).Enabled = Enble
'            End If
        End If
    Next CtrlCntr
End Sub

'Public Function GetWindowsVersion() As String
'
'    Dim OSInfo As OSVERSIONINFO
'    Dim Ret As Integer
'    OSInfo.dwOSVersionInfoSize = 148
'    OSInfo.szCSDVersion = Space$(128)
'    Ret = GetVersionExA(OSInfo)
'
'    With OSInfo
'
'        Select Case .dwPlatformId
'            Case 1
'                If .dwMinorVersion < 10 Then
'
'                    If .dwBuildNumber = 950 Then
'                        GetWindowsVersion = "Windows 95"
'                    ElseIf .dwBuildNumber > 950 Or .dwBuildNumber <= 1080 Then
'                        GetWindowsVersion = "Windows 95 SP1"
'                    Else
'                        GetWindowsVersion = "Windows 95 OSR2"
'                    End If
'
'                ElseIf .dwMinorVersion = 10 Then
'
'                    If .dwBuildNumber = 1998 Then
'                        GetWindowsVersion = "Windows 98"
'                    ElseIf .dwBuildNumber > 1998 Or .dwBuildNumber < 2183 Then
'                        GetWindowsVersion = "Windows 98 SP1"
'                    ElseIf .dwBuildNumber >= 2183 Then
'                        GetWindowsVersion = "Windows 98 SE"
'                    End If
'
'                Else
'                    GetWindowsVersion = "Windows ME"
'                End If
'
'            Case 2
'                If .dwMajorVersion = 3 Then
'                    GetWindowsVersion = "Windows NT 3.51"
'                ElseIf .dwMajorVersion = 4 Then
'                    GetWindowsVersion = "Windows NT 4.0"
'                ElseIf .dwMajorVersion = 5 Then
'
'                    If .dwMinorVersion = 0 Then
'                        GetWindowsVersion = "Windows 2000"
'                    Else
'                        GetWindowsVersion = "Windows XP"
'                    End If
'
'                End If
'
'            Case 3
'                If .dwMajorVersion = 1 Then
'                    GetWindowsVersion = "Windows CE 1.0"
'                ElseIf .dwMajorVersion = 2 Then
'
'                    If .dwMinorVersion = 0 Then
'                        GetWindowsVersion = "Windows CE 2.0"
'                    Else
'                        GetWindowsVersion = "Windows CE 2.1"
'                    End If
'
'                Else
'                    GetWindowsVersion = "Windows CE 3.0"
'                End If
'
'            Case Else
'                GetWindowsVersion = "Unable To get Windows Version"
'        End Select
'
'End With
'
'End Function