usefuls.bas

Rjindeal加密算法

        TimerElapsed = False
    Else
        If PerformanceFrequency.LowPart = 1000 And PerformanceFrequency.HighPart = 0 Then
            ' Using standard windows timer
            Dec = CDec(timeGetTime)
            If Dec < 0 Then
                Dec = CDec(Dec + (2147483648# * 2))
            End If
            If Dec > EndTime Then
                TimerElapsed = True
            Else
                TimerElapsed = False
            End If
        Else
            If QueryPerformanceCounter(CurrentTime) Then
                Dec = CDec(CurrentTime.LowPart)
                ' make this UNSIGNED
                If Dec < 0 Then
                    Dec = CDec(Dec + (2147483648# * 2))
                End If
                Dec = CDec(Dec + (CurrentTime.HighPart * 2147483648# * 2))
                If Dec > EndTime Then
                    TimerElapsed = True
                Else
                    TimerElapsed = False
                End If
            Else
                ' Should never happen in theory
                Err.Raise vbObjectError + 2, "Timer Elapsed", "Your performance timer has stopped functioning!!!"
                TimerElapsed = True
            End If
        End If
    End If
End Function

'-------------------------------------------
' File handling functions
'-------------------------------------------
' simple check if a file exists
Public Function FileExists(Path As String) As Boolean
    FileExists = Len(Dir(Path)) > 0
End Function

'-------------------------------------------
' "Is" functions
'-------------------------------------------
Public Function IsOdd(Num As Long) As Boolean
    IsOdd = -(Num And 1)
End Function

Public Function IsEven(Num As Long) As Boolean
    IsEven = ((Num And 1) = 0)
End Function

Public Function IsDivisible(Numerator As Long, Divisor As Long) As Boolean
    IsDivisible = (Numerator Mod Divisor = 0) ' Credit to Ulli on PSC here for this
End Function

' Detects whether a control is part of a control array
Function IsControlArray(Cntrl As Control) As Boolean
    On Error GoTo ErrHandler
    If Cntrl.Index Then ' If control is not an array, then error 343 is thrown here
    End If
    IsControlArray = True
    Exit Function
ErrHandler:
    If Err.Number = 343 Then ' object is not an array
        IsControlArray = False
        Exit Function
    Else ' any other error
        IsControlArray = False
        Exit Function
    End If
End Function

' Special Asynchronous Functions
' Processes all events to be raised to a specific control (such as Click, KeyDown, etc.)
' Should generally be faster than the more generic DoEvents.  However, dangerous if
' you don't know what you're doing.
Public Sub DoEventsForControl(hwnd As Long)
Dim tmpMsg As MSG
    Do While PeekMessage(tmpMsg, hwnd, 0, 0, PM_REMOVE)
        TranslateMessage tmpMsg
        DispatchMessage tmpMsg
    Loop
End Sub

'-------------------------------------------
' Print Engine functions
'-------------------------------------------
Public Sub PrintEngineCentreText(Text As String)
Dim TW As Long
    With Printer
        TW = .TextWidth(Text)
        .CurrentX = (.Width - TW) / 2
        Printer.Print Text
    End With
End Sub

Public Sub PrintEnginePrintAt(Text As String, Optional X As Long = -1, Optional Y As Long = -1)
    With Printer
        If X >= 0 Then
            .CurrentX = X
        End If
        If Y >= 0 Then
            .CurrentY = Y
        End If
        Printer.Print Text
    End With
End Sub

Public Sub PrintEngineSkipLines(Optional ByVal NumberOfLines As Long = 1)
    With Printer
        While NumberOfLines > 0
            NumberOfLines = NumberOfLines - 1
            Printer.Print ""
        Wend
    End With
End Sub

'-------------------------------------------
' Collision Detection (Sprites)
'-------------------------------------------
' Acknowledgement here goes to Richard Lowe ([e-mail]) for his collision detection
' algorithm which I have used as the basis of my collision detection algorithm.  Some of the logic in
' here is radically different though, and his algorithm originally didn't deallocate memory properly ;-)
Public Function CollisionDetect(ByVal x1 As Long, ByVal y1 As Long, ByVal X1Width As Long, ByVal Y1Height As Long, _
    ByVal Mask1LocX As Long, ByVal Mask1LocY As Long, ByVal Mask1Hdc As Long, ByVal x2 As Long, ByVal y2 As Long, _
    ByVal X2Width As Long, ByVal Y2Height As Long, ByVal Mask2LocX As Long, ByVal Mask2LocY As Long, _
    ByVal Mask2Hdc As Long) As Boolean
' I'm going to use RECT types to do this, so that the Windows GDI can do the hard bits for me.
Dim MaskRect1 As RECT
Dim MaskRect2 As RECT
Dim DestRect As RECT
Dim i As Long
Dim j As Long
Dim Collision As Boolean
Dim MR1SrcX As Long
Dim MR1SrcY As Long
Dim MR2SrcX As Long
Dim MR2SrcY As Long
Dim hNewBMP As Long
Dim hPrevBMP As Long
Dim tmpObj As Long
Dim hMemDC As Long


    MaskRect1.Left = x1
    MaskRect1.Top = y1
    MaskRect1.Right = x1 + X1Width
    MaskRect1.Bottom = y1 + Y1Height
    MaskRect2.Left = x2
    MaskRect2.Top = y2
    MaskRect2.Right = x2 + X2Width
    MaskRect2.Bottom = y2 + Y2Height
    i = IntersectRect(DestRect, MaskRect1, MaskRect2)
    If i = 0 Then
        CollisionDetect = False
    Else
        ' The two rectangles intersect, so let's go to a pixel by pixel comparison
        
        ' Set SourceX and Y values for both Mask HDC's...
        If x1 <= x2 Then
            MR1SrcX = X1Width - (DestRect.Right - DestRect.Left)
            MR2SrcX = 0
        Else
            MR1SrcX = 0
            MR2SrcX = X2Width - (DestRect.Right - DestRect.Left)
        End If
        If y1 <= y2 Then
            MR1SrcY = Y1Height - (DestRect.Bottom - DestRect.Top)
            MR2SrcY = 0
        Else
            MR1SrcY = 0
            MR2SrcY = Y2Height - (DestRect.Bottom - DestRect.Top)
        End If
        
        ' Allocate memory DC and Bitmap in which to do the comparison
        hMemDC = CreateCompatibleDC(Screen.ActiveForm.hdc)
        hNewBMP = CreateCompatibleBitmap(Screen.ActiveForm.hdc, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top)
        hPrevBMP = SelectObject(hMemDC, hNewBMP)

        ' Blit the first sprite into it
        i = BitBlt(hMemDC, 0, 0, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, _
                Mask1Hdc, MR1SrcX + Mask1LocX, MR1SrcY + Mask1LocY, vbSrcCopy)

        ' Logical OR the second sprite with the first sprite
         i = BitBlt(hMemDC, 0, 0, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, _
                Mask2Hdc, MR2SrcX + Mask2LocX, MR2SrcY + Mask2LocY, vbSrcPaint)
        
        Collision = False
        For i = 0 To DestRect.Bottom - DestRect.Top - 1
            For j = 0 To DestRect.Right - DestRect.Left - 1
                If GetPixel(hMemDC, j, i) = 0 Then ' If there are any black pixels
                    Collision = True
                    Exit For
                End If
            Next
            If Collision = True Then
                Exit For
            End If
        Next
        CollisionDetect = Collision
        
        ' Destroy any allocated objects and DC's
        tmpObj = SelectObject(hMemDC, hPrevBMP)
        tmpObj = DeleteObject(tmpObj)
        tmpObj = DeleteDC(hMemDC)
    End If
End Function

Public Function PadHexStr(Str As String, Optional PadWidth As Long = 2) As String
Dim i As Long
    i = Len(Str)
    If i < PadWidth Then
        PadHexStr = RepeatChar("0", PadWidth - i) & Str
    Else
        PadHexStr = Str
    End If
End Function

Public Function FourBytesToLong(PB1 As Byte, pb2 As Byte, pb3 As Byte, pb4 As Byte) As Long
    FourBytesToLong = LshL(PB1, 24) Or LshL(pb2, 16) Or LshL(pb3, 8) Or pb4 ' I HATE I HATE I HATE VISUAL BASIC!!!!!
End Function

Public Function RepeatChar(pChar As String, pTimes As Long) As String
Dim i As Long
    For i = 1 To pTimes
        RepeatChar = RepeatChar & pChar
    Next
End Function

' Yuk.
Public Function HexStrToLong(Str As String) As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim B As Long

    j = 28
    k = 1
    B = 0
    Do While j >= 0
        i = Asc(Mid(Str, k, 1))
        If i >= 48 And i <= 57 Then
            B = B Or LshL(i - 48, j)
        ElseIf i >= 65 And i <= 70 Then
            B = B Or LshL(i - 65 + 10, j)
        ElseIf i >= 97 And i <= 102 Then
            B = B Or LshL(i - 97 + 10, j)
        Else
            Err.Raise 1, "HexStrToLong", "Invalid Hex String Specified": Exit Function
        End If
        k = k + 1
        j = j - 4
    Loop
    HexStrToLong = B
End Function

' Translates a string such as '000000000000000000110101' to a long.
Public Function BinStrToLong(Str As String) As Long
    
End Function

' Translates hex string such as "0A" or "Fe" or "70" to a byte value.  String must be 2 chars or you'll get an error back.
Public Function HexStrToByte(Str As String) As Byte
Dim i As Byte
Dim B As Byte
    On Error GoTo ErrHandler
    i = Asc(Mid(Str, 1, 1))
    If i >= 48 And i <= 57 Then
        B = BshL(i - 48, 4)
    ElseIf i >= 65 And i <= 70 Then
        B = BshL(i - 65 + 10, 4)
    ElseIf i >= 97 And i <= 102 Then
        B = BshL(i - 97 + 10, 4)
    Else
        Err.Raise 1, "HexStrToByte", "Invalid Hex String Specified": Exit Function
    End If
    
    i = Asc(Mid(Str, 2, 1))
    If i >= 48 And i <= 57 Then
        B = B Xor (i - 48)
    ElseIf i >= 65 And i <= 70 Then
        B = B Xor (i - 65 + 10)
    ElseIf i >= 97 And i <= 102 Then
        B = B Xor (i - 97 + 10)
    Else
        Err.Raise 1, "HexStrToByte", "Invalid Hex String Specified": Exit Function
    End If
    HexStrToByte = B
    Exit Function
ErrHandler:
    Err.Raise Err.Number, Err.Source, Err.Description
    HexStrToByte = 0
    Exit Function
End Function