?? usefuls.bas
字號:
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 (riklowe@hotmail.com) 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
' 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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -