moddeclarations.bas

一个游戏的原代码

Attribute VB_Name = "modDeclarations"
Option Explicit
'''Ben鰐igt um die inneren Koordinaten eines Formulars zu ermitteln (den Bereich ohne Titel-leiste)
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'''

'Zwei Routinen die sehr eng mit dem System verbunden sind und ein sehr genaues ergebnis liefern
'Als Alternative k鰊nte man auch GetTickCount verwenden, aber dann w鋜e die Berechnung nicht so genau
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Declare Function GetTickCount Lib "kernel32" () As Long

Public MemMgr As New Cls_MemoryMgr

Public DirectX As New DirectX8
Public Direct3D As Direct3D8
Public D3Ddevice As Direct3DDevice8
Public DisplaySettings As D3DDISPLAYMODE
Public D3DWindow As D3DPRESENT_PARAMETERS

Public D3DX As New D3DX8

Public matView As D3DMATRIX
Public matWorld As D3DMATRIX
Public matProj As D3DMATRIX


'''FPS-Variablen
Public FPS_Current As Single            'Unsere FPS
Public FPS_timefactor As Single       'Zeit die vergangen ist seid dem
                                        'der letzte Frame dargestellt wurde
                                        'timefactor l鋝st sich zum Zeit basierten steuern von Abl鋟fen
                                        'einsetzen (wenn eine Taste gedr點kt wurde kann man
                                        'ermitteln wie lange sie schon gedr點kt wurde und daraus die
                                        'st鋜ke der Auswirkung errechnen)
Public FPS_tLastFrame As Currency       'Speichert die System-Zeit als der letzte Frame gezeichnet wurde
Public FPS_tLastFPSdisplay As Currency  'Speichert zeit der letzten FPS-Berchnung
Public FPS_Counter As Currency          'Z鋒lt die Frames
'''

'''Text-Variablen
Public DXfont As D3DXFont       'Unser fertig erstellter Font
Public DXfontDesc As IFont      'Die Font-Description (nur tempor鋜 genutzt)
Public fnt As New StdFont       'Ein ganz normaler Font
Public TextRect As RECT         'Das RECT-Objekt, das den Bereich definiert
                                'in dem wir den Text ausgeben m鯿hten
'''

'''Screenshot-Variablen
Public ScreenShotSurface As Direct3DSurface8
Public SrcPalette As PALETTEENTRY
Public SrcRect As RECT      'Wir m黶sen den Teil des angezeigten Bildes ausschneiden
                            'der f黵 uns relevant ist
'''


Public Const PI As Single = 3.14159265358979
Public Const Rad  As Single = PI / 180

'Sin/Cos-Arrays
Private SinArr(0 To 1440) As Single
Private CosArr(0 To 1440) As Single
Private tAngle As Single

Public i As Long

Public Takt As Currency
Public Dauer As Currency

Public Sub ScreenShot(SavePath As String)
D3Ddevice.GetFrontBuffer ScreenShotSurface

Dim lp As POINTAPI
ClientToScreen frmMain.Picture1.hwnd, lp
GetWindowRect frmMain.Picture1.hwnd, SrcRect
With SrcRect
.bottom = .bottom - (lp.X - .Left)
.Right = .Right - (lp.X - .Left)
.Left = lp.X: .Top = lp.Y
End With
D3DX.SaveSurfaceToFile SavePath, D3DXIFF_BMP, ScreenShotSurface, SrcPalette, SrcRect
End Sub

Public Function QPTimer() As Currency
  If Takt = 0 Then
    'einmal die Taktfrequenz bestimmen:
    QueryPerformanceFrequency Takt
  End If
  
  'aktuelle Zeit holen:
  QueryPerformanceCounter Dauer
  
  'Zeit in Sekunden umrechnen:
  QPTimer = Dauer / Takt
End Function

Public Function CreateFont(FontName As String, FontSize As Long, FontBold As Boolean, FontItalic As Boolean, FontUnderline As Boolean) As D3DXFont
DXfontDesc.Bold = FontBold
DXfontDesc.Name = FontName
DXfontDesc.Size = FontSize
DXfontDesc.Italic = FontItalic
DXfontDesc.Underline = FontUnderline
Set CreateFont = D3DX.CreateFont(D3Ddevice, DXfontDesc.hFont)
End Function

Public Sub TextBox(txtString As String, Font As D3DXFont, txtX As Long, txtY As Long, txtWidth As Long, txtHeight As Long, FontColor As Long)
On Error GoTo ErrOut:
TextRect.Left = txtX
TextRect.Top = txtY
TextRect.bottom = txtY + txtHeight
TextRect.Right = txtX + txtWidth
D3DX.DrawText Font, FontColor, txtString, TextRect, DT_TOP Or DT_LEFT Or DT_WORDBREAK
ErrOut:
End Sub


Public Sub CalculateVars()
For i = 0 To 1440
    SinArr(i) = sIn((i / 4) * Rad)
    CosArr(i) = Cos((i / 4) * Rad)
Next
End Sub

Public Function Sine(Angle As Single) As Single
tAngle = (Angle * 4) \ 1
Do While tAngle < 0 Or tAngle > 1440
    If tAngle > 1440 Then tAngle = tAngle - 1440
    If tAngle < 0 Then tAngle = tAngle + 1440
Loop
Sine = SinArr(tAngle)
End Function

Public Function CoSine(Angle As Single) As Single
tAngle = (Angle * 4) \ 1
Do While tAngle < 0 Or tAngle > 1440
    If tAngle > 1440 Then tAngle = tAngle - 1440
    If tAngle < 0 Then tAngle = tAngle + 1440
Loop
CoSine = CosArr(tAngle)
End Function


'Vorhandenheit einer Datei / eines Ordners ermitteln
Public Function FileExists(file As String) As Boolean
   On Error Resume Next
   If file = "" Then Exit Function
   FileExists = Dir(file) <> ""
End Function
Public Function FolderExists(Folder As String) As Boolean
   On Error Resume Next
   FolderExists = False
   FolderExists = Dir(Folder, vbDirectory) <> ""
End Function
'Mit dieser Funktion kann man einen Pfad zu einer Datei
'in den Pfad zum 黚ergeordneten Ordner umwandeln ("C:\ordner\datei.xxx" wird zu "C:\ordner\")
Public Function GetFolder(StringFilePath As String) As String
GetFolder = Left$(StringFilePath, InStrRev(StringFilePath, "\"))
End Function

'Diese Funktion wird dazu gebraucht sie sucht nach einer Datei
'in verschiedenen m鰃lichen Ordnern
Public Function FindFile(TextureFile As String, Xfile As String) As String
If FileExists(TextureFile) And Left(TextureFile, 3) = "C:\" Then
FindFile = TextureFile
ElseIf FileExists(App.path & "\" & TextureFile) Then
FindFile = App.path & "\" & TextureFile
ElseIf FileExists(App.path & TextureFile) Then
FindFile = App.path & TextureFile
ElseIf FileExists(GetFolder(Xfile) & "\" & TextureFile) Then
FindFile = GetFolder(Xfile) & "\" & TextureFile
ElseIf FileExists(GetFolder(Xfile) & TextureFile) Then
FindFile = GetFolder(Xfile) & TextureFile
Else
'Datei nicht gefunden
FindFile = "notfound"
End If
End Function

Public Function MakeVector(X As Single, Y As Single, Z As Single) As D3DVECTOR
    MakeVector.X = X
    MakeVector.Y = Y
    MakeVector.Z = Z
End Function

Public Function CreateD3DColorVal(A As Single, r As Single, g As Single, B As Single) As D3DCOLORVALUE
CreateD3DColorVal.A = A
CreateD3DColorVal.r = r
CreateD3DColorVal.g = g
CreateD3DColorVal.B = B
End Function