by Walter Eigner (15 Submissions)
Category: Graphics
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sat 15th May 2004
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
A simple directX engine. Allows the loading and painting of images much easier that normal usage of direct X. Requires Direct X7 runtimes to
API Declarations
Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim Primary As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim ddsdPrimary As DDSURFACEDESC2
Dim ddsdScreen As DDSURFACEDESC2
Dim bRestore As Boolean
Dim bInit As Boolean
Dim Surfaces() As DirectDrawSurface7
Dim ddsdSurfaces() As DDSURFACEDESC2
Dim Loading As DirectDrawSurface7
Dim ddsdLoading As DDSURFACEDESC2
Dim BmpPath As String
Dim LoadPercent As Single
Dim ParentPath As String
Dim lForeColor As Long
Dim lFillColor As Long
Public HasInit As Boolean
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
VBcoders
Sub InitDX(frm As Form, ResolutionX As Integer, ResolutionY As Integer, ResolutionBpp As Integer, loadingImageSrc As String, bmpDataSrc As String, ForeColor As Long, FillColor As Long)
On Local Error GoTo errOut
Set DD7 = DX7.DirectDrawCreate("")
frm.Show
ShowCursor 0
lForeColor = ForeColor
lFillColor = FillColor
ParentPath = GetParentPath
Call DD7.SetCooperativeLevel(frm.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
Call DD7.SetDisplayMode(ResolutionX, ResolutionY, ResolutionBpp, 0, DDSDM_DEFAULT)
ddsdPrimary.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
ddsdPrimary.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
ddsdPrimary.lBackBufferCount = 1
Set Primary = DD7.CreateSurface(ddsdPrimary)
Dim caps As DDSCAPS2
caps.lCaps = DDSCAPS_BACKBUFFER
Set BackBuffer = Primary.GetAttachedSurface(caps)
BackBuffer.GetSurfaceDesc ddsdScreen
InitSurfaces loadingImageSrc, bmpDataSrc
HasInit = True
Do While bInit
blt loadingImageSrc, bmpDataSrc
DoEvents
Loop
errOut:
EndIt frm
End Sub
Sub EndDX(frm As Form)
If bInit = False Then
EndIt frm
Else
bInit = False
End If
End Sub
Private Sub EndIt(frm As Form)
On Local Error GoTo errOut
ShowCursor 1
Call DD7.RestoreDisplayMode
Call DD7.SetCooperativeLevel(frm.hWnd, DDSCL_NORMAL)
HasInit = False
errOut:
End
End Sub
Private Sub InitSurfaces(loadingImageSrc As String, bmpDataSrc As String)
Dim i As Integer
Dim MaxSurface As Integer
Dim SurfaceLocation As String
Set Loading = Nothing
ddsdLoading.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsdLoading.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsdLoading.lWidth = ddsdScreen.lWidth
ddsdLoading.lHeight = ddsdScreen.lHeight
Set Loading = DD7.CreateSurfaceFromFile(ParentPath & loadingImageSrc, ddsdLoading)
MaxSurface = Val(ReadIniString(ParentPath & bmpDataSrc, "Images", "Total", 0))
If MaxSurface = 0 Then Exit Sub
ReDim Surfaces(1 To MaxSurface)
ReDim ddsdSurfaces(1 To MaxSurface)
For i = 1 To MaxSurface
LoadPercent = 100 * (i / MaxSurface)
SurfaceLocation = ReadIniString(ParentPath & bmpDataSrc, "Images", "Image" & i, "")
Set Surfaces(i) = Nothing
ddsdSurfaces(i).lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsdSurfaces(i).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsdSurfaces(i).lWidth = ddsdScreen.lWidth
ddsdSurfaces(i).lHeight = ddsdScreen.lHeight
Set Surfaces(i) = DD7.CreateSurfaceFromFile(ParentPath & SurfaceLocation, ddsdSurfaces(i))
If (i - 1) / 2 = Math.Round((i - 1) / 2) Then blt loadingImageSrc, bmpDataSrc
DoEvents
Next
bInit = True
End Sub
Sub BltSurface(ImageNumber As Integer, X1 As Single, Y1 As Single)
Dim dRect As RECT
dRect.Top = Y1
dRect.Left = X1
dRect.Bottom = ddsdScreen.lHeight
dRect.Right = ddsdScreen.lWidth
Dim sRect As RECT
sRect.Top = 0
sRect.Left = 0
sRect.Bottom = ddsdScreen.lHeight
sRect.Right = ddsdScreen.lWidth
BackBuffer.blt dRect, Surfaces(ImageNumber), sRect, DDBLT_DONOTWAIT
End Sub
Sub blt(loadingImageSrc As String, bmpDataSrc As String)
On Local Error GoTo errOut
Dim ddrval As Long
Dim rBack As RECT
bRestore = False
Do Until ExModeActive
DoEvents
bRestore = True
Loop
DoEvents
If bRestore Then
bRestore = False
DD7.RestoreAllSurfaces
bInit = False
InitSurfaces loadingImageSrc, bmpDataSrc
End If
rBack.Bottom = ddsdScreen.lHeight
rBack.Right = ddsdScreen.lWidth
ddrval = BackBuffer.BltColorFill(rBack, 0)
If bInit = False Then
Dim IFontTitle As New StdFont
BackBuffer.BltFast 0, 0, Loading, rBack, DDBLTFAST_DONOTWAIT
BackBuffer.setDrawWidth 2
BackBuffer.SetFillStyle 1
BackBuffer.SetFillColor 0
BackBuffer.SetForeColor lForeColor
BackBuffer.DrawRoundedBox ddsdScreen.lWidth / 2 - 75, ddsdScreen.lHeight - 60, ddsdScreen.lWidth / 2 + 75, ddsdScreen.lHeight - 30, 16, 16
BackBuffer.setDrawWidth 1
BackBuffer.SetFillStyle 0
BackBuffer.SetFillColor lFillColor
BackBuffer.SetForeColor lForeColor
BackBuffer.DrawRoundedBox ddsdScreen.lWidth / 2 - 75, ddsdScreen.lHeight - 60, ddsdScreen.lWidth / 2 - 75 + (150 * (LoadPercent / 100)), ddsdScreen.lHeight - 30, 16, 16
IFontTitle.Size = 12
IFontTitle.Italic = False
BackBuffer.SetFont IFontTitle
BackBuffer.DrawText ddsdScreen.lWidth / 2 - 8, ddsdScreen.lHeight - 55, Math.Round(LoadPercent) & "%", False
Else
End If
Primary.Flip Nothing, DDFLIP_WAIT
errOut:
End Sub
Private Function ExModeActive() As Boolean
Dim TestCoopRes As Long
TestCoopRes = DD7.TestCooperativeLevel
If (TestCoopRes = DD_OK) Then
ExModeActive = True
Else
ExModeActive = False
End If
End Function
Private Sub WriteIniString(IniFile As String, Major As String, Minor As String, Value As String)
WritePrivateProfileString Major, Minor, Value, IniFile
End Sub
Private Function ReadIniString(IniFile As String, Major As String, Minor As String, Default As String)
Dim str As String
str = Space(1024)
GetPrivateProfileString Major, Minor, Default, str, 1024, IniFile
str = Trim(str)
If Len(str) >= 1 Then
If Right(str, 1) = Chr(0) Then str = Left(str, Len(str) - 1)
End If
ReadIniString = str
End Function
Private Function GetParentPath() As String
GetParentPath = App.Path
If Right(GetParentPath, 1) <> "\" Then GetParentPath = GetParentPath & "\"
End Function
No comments have been posted about A simple directX engine. Allows the loading and painting of images much easier that normal usage of. Why not be the first to post a comment about A simple directX engine. Allows the loading and painting of images much easier that normal usage of.
