Initial commit: ROW Client source code

Game client codebase including:
- CharacterActionControl: Character and creature management
- GlobalScript: Network, items, skills, quests, utilities
- RYLClient: Main client application with GUI and event handlers
- Engine: 3D rendering engine (RYLGL)
- MemoryManager: Custom memory allocation
- Library: Third-party dependencies (DirectX, boost, etc.)
- Tools: Development utilities

🤖 Generated with [Claude Code](https://claude.com/claude-code)

Co-Authored-By: Claude <noreply@anthropic.com>
This commit is contained in:
2025-11-29 16:24:34 +09:00
commit e067522598
5135 changed files with 1745744 additions and 0 deletions

View File

@@ -0,0 +1,526 @@
VERSION 5.00
Begin VB.Form frmMain
BackColor = &H00000000&
BorderStyle = 4 'Fixed ToolWindow
Caption = "Club Metamorphous"
ClientHeight = 7140
ClientLeft = 3510
ClientTop = 1890
ClientWidth = 8310
ForeColor = &H0000C000&
Icon = "ClubMet.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 476
ScaleMode = 3 'Pixel
ScaleWidth = 554
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdExit
BackColor = &H0080FF80&
Cancel = -1 'True
Caption = "Exit"
Height = 495
Left = 240
TabIndex = 12
Top = 6600
Width = 1215
End
Begin VB.CommandButton cmdAdmission
BackColor = &H00FFC0FF&
Caption = "Admission"
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 240
Style = 1 'Graphical
TabIndex = 10
Top = 6000
Width = 1215
End
Begin VB.CommandButton cmdSpecials
BackColor = &H008080FF&
Caption = "Dinner Specials"
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 240
Style = 1 'Graphical
TabIndex = 9
Top = 5400
Width = 1215
End
Begin VB.CommandButton cmdDirections
BackColor = &H0080C0FF&
Caption = "Directions"
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 240
Style = 1 'Graphical
TabIndex = 8
Top = 4800
Width = 1215
End
Begin VB.PictureBox mnCan
BackColor = &H80000007&
BorderStyle = 0 'None
Height = 3795
Left = 2400
ScaleHeight = 253
ScaleMode = 3 'Pixel
ScaleWidth = 385
TabIndex = 7
Top = 1680
Width = 5775
End
Begin VB.Label lblStuff
BackColor = &H80000007&
Caption = "Label2"
ForeColor = &H8000000E&
Height = 1455
Left = 2340
TabIndex = 11
Top = 5580
Width = 5835
End
Begin VB.Label lblSunday
AutoSize = -1 'True
BackColor = &H00000000&
Caption = "Sunday"
BeginProperty Font
Name = "Times New Roman"
Size = 20.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000C000&
Height = 465
Left = 240
TabIndex = 6
Top = 4200
Width = 1305
End
Begin VB.Label lblSaturday
AutoSize = -1 'True
BackColor = &H00000000&
Caption = "Saturday"
BeginProperty Font
Name = "Times New Roman"
Size = 20.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000C000&
Height = 465
Left = 240
TabIndex = 5
Top = 3600
Width = 1605
End
Begin VB.Label lblFriday
AutoSize = -1 'True
BackColor = &H00000000&
Caption = "Friday"
BeginProperty Font
Name = "Times New Roman"
Size = 20.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000C000&
Height = 465
Left = 240
TabIndex = 4
Top = 3000
Width = 1185
End
Begin VB.Label lblThursday
AutoSize = -1 'True
BackColor = &H00000000&
Caption = "Thursday"
BeginProperty Font
Name = "Times New Roman"
Size = 20.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000C000&
Height = 465
Left = 240
TabIndex = 3
Top = 2400
Width = 1695
End
Begin VB.Label lblWednesday
AutoSize = -1 'True
BackColor = &H00000000&
Caption = "Wednesday"
BeginProperty Font
Name = "Times New Roman"
Size = 20.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 465
Left = 240
TabIndex = 2
Top = 1800
Width = 2025
End
Begin VB.Label lblName
Alignment = 2 'Center
BackColor = &H00000000&
Caption = "Club Metamorphous"
BeginProperty Font
Name = "Times New Roman"
Size = 36
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000080FF&
Height = 915
Left = 480
TabIndex = 1
Top = 0
Width = 7455
End
Begin VB.Label Label1
BackColor = &H00000000&
Caption = """The only thing that stays the same is a good time!"""
BeginProperty Font
Name = "Times New Roman"
Size = 15.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = -1 'True
Strikethrough = 0 'False
EndProperty
ForeColor = &H000080FF&
Height = 495
Left = 840
TabIndex = 0
Top = 1020
Width = 6855
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: ClubMet.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This application uses conditional compilation. To run this sample in the IDE, you
'must first go to Project Properties (Project Menu-> Properties). Then on the Make tab
'change the RunInIDE=0 to RunInIDE=1.
'This sample also shows developers how to combine the DX7 and DX8 DLL's to create
'an app with the latest DMusic and still use older functionality like DDraw
Private dx As New DXVBLibA.DirectX8
Dim day As Integer
Dim sJazz As DXVBLibA.DirectMusicStyle8
Dim sDance As DXVBLibA.DirectMusicStyle8
Dim sBigBand As DXVBLibA.DirectMusicStyle8
Dim sDisco As DXVBLibA.DirectMusicStyle8
Dim sClassical As DXVBLibA.DirectMusicStyle8
Dim sHeartland As DXVBLibA.DirectMusicStyle8
Dim cmp As DXVBLibA.DirectMusicChordMap8
Dim com As DXVBLibA.DirectMusicComposer8
Dim perf As DXVBLibA.DirectMusicPerformance8
Dim seg As DXVBLibA.DirectMusicSegment8
Dim loader As DXVBLibA.DirectMusicLoader8
Dim currentstyle As DXVBLibA.DirectMusicStyle8
Dim LabelNumber As Integer
Dim runit As Boolean
Private Sub cmdAdmission_Click()
Call perf.PlaySegmentEx(currentstyle.GetMotif(currentstyle.GetMotifName(2)), DMUS_SEGF_SECONDARY Or DMUS_SEGF_BEAT, 0)
lblStuff.Caption = ChangeStuffLabel(6)
End Sub
Private Sub cmdDirections_Click()
Call perf.PlaySegmentEx(currentstyle.GetMotif(currentstyle.GetMotifName(0)), DMUS_SEGF_SECONDARY Or DMUS_SEGF_BEAT, 0)
lblStuff.Caption = ChangeStuffLabel(0)
End Sub
Private Sub cmdExit_Click()
runit = False
Unload Me
End Sub
Private Sub cmdSpecials_Click()
Call perf.PlaySegmentEx(currentstyle.GetMotif(currentstyle.GetMotifName(1)), DMUS_SEGF_SECONDARY Or DMUS_SEGF_BEAT, 0)
lblStuff.Caption = ChangeStuffLabel(LabelNumber)
End Sub
Private Function ChangeStuffLabel(Index As Integer) As String
Dim tString(9) As String
Call ClearlblStuff
'directions
tString(0) = "Corner of 4th and Stewart, next to the new stadium!"
'dinners
tString(1) = "London Broil with Hollandaise sauce, baby red potatoes, green vegetables, and Lobster Bisque soup."
tString(2) = "Grilled Mahi-Mahi on a bed of rice pilaf, green vegetables, and Ceasar salad"
tString(3) = "Chicken Cordon Bleu, steamed vegetables, wild lemon rice, and clam chowder"
tString(4) = "Bacon CheeseBurger, onion rings, and a vanilla shake"
tString(5) = "Salmon in parchment, rice pilaf, green vegetables, and lentil soup."
'Admission
tString(6) = "Age 14 - 18, $4.50, age 19 and up, $7.00"
ChangeStuffLabel = tString(Index)
End Function
Private Sub ClearlblStuff()
lblStuff.Caption = ""
End Sub
Private Sub Form_Load()
On Error GoTo err_out
Show
ClearlblStuff
InitDD hwnd, mnCan
DoEvents
initDMusic
DoEvents
runit = True
Do
MoveFrame day
DoEvents
Loop
End
err_out:
MsgBox "Could not start application!", vbApplicationModal
End
End Sub
Private Sub initDMusic()
Dim dma As DMUS_AUDIOPARAMS
On Error GoTo FailedInit
Set perf = dx.DirectMusicPerformanceCreate
Set com = dx.DirectMusicComposerCreate
Set loader = dx.DirectMusicLoaderCreate
perf.InitAudio Me.hwnd, DMUS_AUDIOF_ALL, dma, , DMUS_APATH_SHARED_STEREOPLUSREVERB, 128
perf.SetMasterAutoDownload True
'Load the objects
#If RunInIDE = 1 Then
Dim sMedia As String
sMedia = FindMediaDir("bigband.sty")
If sMedia <> vbNullString Then 'Media is not in current folder
If (Left$(sMedia, 2) <> Left$(CurDir, 2)) And (InStr(Left$(sMedia, 2), ":") > 0) Then ChDrive Left$(sMedia, 2)
ChDir sMedia
End If
Set sBigBand = loader.LoadStyle("BIGBAND.STY")
Set sJazz = loader.LoadStyle("JAZZ.STY")
Set sDisco = loader.LoadStyle("DISCO.STY")
Set sClassical = loader.LoadStyle("CLASSICAL.STY")
Set sDance = loader.LoadStyle("DANCEMIX.STY")
Set sHeartland = loader.LoadStyle("HEARTLAND.STY")
Set currentstyle = sHeartland
Set cmp = loader.LoadChordMap("CHORDMAP.CDM")
#Else
Set sBigBand = loader.LoadStyleFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "BIGBAND")
Set sJazz = loader.LoadStyleFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "JAZZ")
Set sDisco = loader.LoadStyleFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "DISCO")
Set sClassical = loader.LoadStyleFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "CLASSICAL")
Set sDance = loader.LoadStyleFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "DANCEMIX")
Set sHeartland = loader.LoadStyleFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "HEARTLAND")
Set currentstyle = sHeartland
Set cmp = loader.LoadChordMapFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "CHORDMAP")
#End If
Set seg = com.ComposeSegmentFromShape(sHeartland, 64, 0, 1, True, False, cmp)
Call perf.PlaySegmentEx(seg, 0, 0)
Exit Sub
FailedInit:
MsgBox "Could not initialize DirectMusic." & vbCrLf & "This sample will exit.", vbOKOnly Or vbInformation, "Exiting..."
Unload Me
End Sub
Private Sub ChangeMusic()
Set seg = com.ComposeSegmentFromShape(currentstyle, 64, 0, 2, False, False, cmp)
Call com.AutoTransition(perf, seg, DMUS_COMMANDT_FILL, DMUS_COMPOSEF_MEASURE, cmp)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
runit = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Not (perf Is Nothing) Then perf.CloseDown
End
End Sub
Private Sub lblFriday_Click()
ClearlblStuff
Set currentstyle = sDisco
ChangeMusic
day = 2: LabelNumber = 3
lblStuff.Caption = LoadMSg(2)
End Sub
Private Sub lblFriday_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
lblName.Font = "Courier New"
lblName.ForeColor = &H8080FF
lblFriday.ForeColor = &HFF&
lblWednesday.ForeColor = &HC000&
lblThursday.ForeColor = &HC000&
lblSaturday.ForeColor = &HC000&
lblSunday.ForeColor = &HC000&
End Sub
Private Sub lblSaturday_Click()
ClearlblStuff
Set currentstyle = sDance
ChangeMusic
day = 6: LabelNumber = 4
lblStuff.Caption = LoadMSg(3)
End Sub
Private Sub lblSaturday_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
lblName.Font = "Tahoma"
lblName.ForeColor = &HC00000
lblSaturday.ForeColor = &HFF&
lblWednesday.ForeColor = &HC000&
lblThursday.ForeColor = &HC000&
lblFriday.ForeColor = &HC000&
lblSunday.ForeColor = &HC000&
End Sub
Private Sub lblSunday_Click()
ClearlblStuff
Set currentstyle = sClassical
ChangeMusic
day = 5: LabelNumber = 5
lblStuff.Caption = LoadMSg(4)
End Sub
Private Sub lblSunday_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
lblName.Font = "Garamond"
lblName.ForeColor = &HFFC0C0
lblSunday.ForeColor = &HFF&
lblWednesday.ForeColor = &HC000&
lblThursday.ForeColor = &HC000&
lblFriday.ForeColor = &HC000&
lblSaturday.ForeColor = &HC000&
End Sub
Private Sub lblThursday_Click()
ClearlblStuff
Set currentstyle = sJazz
ChangeMusic
day = 3: LabelNumber = 2
lblStuff.Caption = LoadMSg(1)
End Sub
Private Sub lblThursday_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
lblName.Font = "Comic Sans MS"
lblName.ForeColor = &H80FF80
lblThursday.ForeColor = &HFF&
lblWednesday.ForeColor = &HC000&
lblFriday.ForeColor = &HC000&
lblSaturday.ForeColor = &HC000&
lblSunday.ForeColor = &HC000&
End Sub
Private Sub lblWednesday_Click()
ClearlblStuff
Set currentstyle = sBigBand
ChangeMusic
day = 1: LabelNumber = 1
lblStuff.Caption = LoadMSg(0)
End Sub
Private Sub lblWednesday_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
lblName.Font = "Times New Roman"
lblName.ForeColor = &HFFFF&
lblWednesday.ForeColor = &HFF&
lblThursday.ForeColor = &HC000&
lblFriday.ForeColor = &HC000&
lblSaturday.ForeColor = &HC000&
lblSunday.ForeColor = &HC000&
End Sub

View File

@@ -0,0 +1,587 @@
Attribute VB_Name = "basDD"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: basDD.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As DxVBLib.RECT) As Long
'******
'This application uses conditional compilation. To run this sample in the IDE, you
'must first go to Project Properties (Project Menu-> Properties). Then on the Make tab
'change the RunInIDE=0 to RunInIDE=1.
'This sample also shows developers how to combine the DX7 and DX8 DLL's to create
'an app with the latest DMusic and still use older functionality like DDraw
Private dx As New DxVBLib.DirectX7
Private DD As DxVBLib.DirectDraw7
Private DDS As DxVBLib.DirectDrawSurface7
Private dC As DxVBLib.DirectDrawClipper
Private DDSD As DxVBLib.DDSURFACEDESC2
Private DR As DxVBLib.RECT
Private bB As DxVBLib.DirectDrawSurface7
Private BD As DxVBLib.DDSURFACEDESC2
Private BBR As DxVBLib.RECT
Private ar() As Byte
Private AlphaRect As DxVBLib.RECT
Private lPixelDepth As Byte
Private clr As Long
Private cols As Long
Private rows As Long
Private col As Long
Private row As Long
Private Sprites(9) As DxVBLib.DirectDrawSurface7
Private SpriteD(9) As DxVBLib.DDSURFACEDESC2
Private SpriteR(9) As DxVBLib.RECT
Private key(9) As DDCOLORKEY
Private spriteWidth As Integer
Private spriteHeight As Integer
Private currentframe As Integer
Private slide(39) As DxVBLib.RECT
Private Pal(255) As DxVBLib.PALETTEENTRY
Private Palette As DxVBLib.DirectDrawPalette
Private Fish(2) As DxVBLib.DirectDrawSurface7
Private fishD(2) As DxVBLib.DDSURFACEDESC2
Private fishR(2) As DxVBLib.RECT
Private fishkey(2) As DxVBLib.DDCOLORKEY
Private sMSG As String
Private x%, y%
Private tmpR As DxVBLib.RECT
Private Type fis
sR As DxVBLib.RECT
x As Long
y As Single
End Type
Private fi(2) As fis
'Registry constants
Private Const KEY_READ = 131097
Private Const REG_SZ = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
'Registry API's
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
'Sleep
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub InitDD(hwnd As Long, ClipperHwnd As PictureBox)
Dim oPixelFormat As DDPIXELFORMAT
On Local Error GoTo err_
Set DD = dx.DirectDrawCreate(vbNullString)
DD.SetCooperativeLevel hwnd, DDSCL_NORMAL
DDSD.lFlags = DDSD_CAPS
DDSD.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
Set DDS = DD.CreateSurface(DDSD)
Set dC = DD.CreateClipper(0)
dC.SetHWnd ClipperHwnd.hwnd
DDS.SetClipper dC
DDS.GetPixelFormat oPixelFormat
If oPixelFormat.lRGBBitCount < 8 Then
If Not (DD Is Nothing) Then
DD.SetCooperativeLevel frmMain.hwnd, DDSCL_NORMAL
DoEvents
End If
MsgBox "Must run at 16bit color or higher.", vbApplicationModal
End
Else
lPixelDepth = oPixelFormat.lRGBBitCount
End If
BD.lFlags = DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_CAPS
BD.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
BD.lWidth = ClipperHwnd.ScaleWidth
BD.lHeight = ClipperHwnd.ScaleHeight
Set bB = DD.CreateSurface(BD)
BBR.bottom = ClipperHwnd.Height
BBR.Right = ClipperHwnd.Width
loadSprites
AlphaRect.Right = BD.lWidth - 1
AlphaRect.bottom = BD.lHeight - 1
Exit Sub
err_:
If Not (DD Is Nothing) Then
DD.SetCooperativeLevel frmMain.hwnd, DDSCL_NORMAL
DoEvents
End If
MsgBox "Unable to initalize DirectDraw.", vbApplicationModal
End
End Sub
Private Sub loadSprites()
'0
SpriteD(0).lFlags = DDSD_CAPS
SpriteD(0).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
#If RunInIDE = 1 Then
'ide
Dim sMedia As String
sMedia = FindMediaDir("base.bmp")
If sMedia <> vbNullString Then 'Media is not in current folder
If (Left$(sMedia, 2) <> Left$(CurDir, 2)) And (InStr(Left$(sMedia, 2), ":") > 0) Then ChDrive Left$(sMedia, 2)
ChDir sMedia
End If
Set Sprites(0) = DD.CreateSurfaceFromFile("base.bmp", SpriteD(0))
#Else
'exe
Set Sprites(0) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "BASE", SpriteD(0))
#End If
SpriteR(0).Right = SpriteD(0).lWidth
SpriteR(0).bottom = SpriteD(0).lHeight
'1
SpriteD(1).lFlags = DDSD_CAPS
SpriteD(1).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
#If RunInIDE = 1 Then
'ide
Set Sprites(1) = DD.CreateSurfaceFromFile("sax.bmp", SpriteD(1))
#Else
'exe
Set Sprites(1) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "sax", SpriteD(1))
#End If
SpriteR(1).Right = SpriteD(1).lWidth
SpriteR(1).bottom = SpriteD(1).lHeight
'notes
SpriteD(6).lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
SpriteD(6).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
SpriteD(6).lWidth = 64: SpriteD(6).lHeight = 64
#If RunInIDE = 1 Then
'ide
Set Sprites(6) = DD.CreateSurfaceFromFile("notes.bmp", SpriteD(6))
#Else
'exe
Set Sprites(6) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "NOTES", SpriteD(6))
#End If
SpriteR(6).Right = SpriteD(6).lWidth
SpriteR(6).bottom = SpriteD(6).lHeight
key(6).low = 0
key(6).high = 0
Sprites(6).SetColorKey DDCKEY_SRCBLT, key(6)
'2
SpriteD(2).lFlags = DDSD_CAPS
SpriteD(2).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
#If RunInIDE = 1 Then
'ide
Set Sprites(2) = DD.CreateSurfaceFromFile("keys.bmp", SpriteD(2))
#Else
Set Sprites(2) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "KEYS", SpriteD(2))
#End If
SpriteR(2).Right = SpriteD(2).lWidth
SpriteR(2).bottom = SpriteD(2).lHeight
''''''''''''''''''''''''''''''''''''''''''
'loadFish
''''''''''''''''''''''''''''''''''''''''''
fishD(0).lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
fishD(0).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
fishD(0).lWidth = 64: fishD(0).lHeight = 64
fishD(1).lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
fishD(1).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
fishD(1).lWidth = 64: fishD(1).lHeight = 64
fishD(2).lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
fishD(2).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
fishD(2).lWidth = 64: fishD(2).lHeight = 64
#If RunInIDE = 1 Then
'ide
Set Fish(0) = DD.CreateSurfaceFromFile("f1.bmp", fishD(0))
Set Fish(1) = DD.CreateSurfaceFromFile("f2.bmp", fishD(1))
Set Fish(2) = DD.CreateSurfaceFromFile("f3.bmp", fishD(2))
#Else
'exe
Set Fish(0) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "F1", fishD(0))
Set Fish(1) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "F2", fishD(1))
Set Fish(2) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "F3", fishD(2))
#End If
Dim i As Integer
For i = 0 To UBound(Fish)
fishR(i).Right = fishD(i).lWidth
fishR(i).bottom = fishD(i).lHeight
fishkey(i).low = 0
fishkey(i).high = 0
Fish(i).SetColorKey DDCKEY_SRCBLT, fishkey(i)
Next i
'sprite(5) animated hand
SpriteD(5).lFlags = DDSD_CAPS
SpriteD(5).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
#If RunInIDE = 1 Then
'ide
Set Sprites(5) = DD.CreateSurfaceFromFile("handani.bmp", SpriteD(5))
#Else
'exe
Set Sprites(5) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "handani", SpriteD(5))
#End If
SpriteR(5).Right = SpriteD(5).lWidth
SpriteR(5).bottom = SpriteD(5).lHeight
spriteWidth = 272
spriteHeight = 177
cols = SpriteD(5).lWidth / spriteWidth
rows = SpriteD(5).lHeight / spriteHeight
key(5).low = 0
key(5).high = 0
Sprites(5).SetColorKey DDCKEY_SRCBLT, key(5)
'9
SpriteD(9).lFlags = DDSD_CAPS
SpriteD(9).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
#If RunInIDE = 1 Then
'ide
Set Sprites(9) = DD.CreateSurfaceFromFile("bknote.bmp", SpriteD(9))
#Else
'exe
Set Sprites(9) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "bknote", SpriteD(9))
#End If
SpriteR(9).Right = SpriteD(9).lWidth
SpriteR(9).bottom = SpriteD(9).lHeight
StripVert slide(), SpriteR(9).Right, SpriteR(9).bottom
'8
SpriteD(8).lFlags = DDSD_CAPS
SpriteD(8).ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
#If RunInIDE = 1 Then
'ide
Set Sprites(8) = DD.CreateSurfaceFromFile("dance.bmp", SpriteD(8))
#Else
'exe
Set Sprites(8) = DD.CreateSurfaceFromResource(AddDirSep(App.Path) & App.EXEName & ".exe", "dance", SpriteD(8))
#End If
SpriteR(8).Right = SpriteD(8).lWidth
SpriteR(8).bottom = SpriteD(8).lHeight
End Sub
Public Sub MoveFrame(Index As Integer)
On Local Error GoTo err_
Select Case Index
Case 0
bB.Blt BBR, Sprites(Index), SpriteR(Index), DDBLT_WAIT
bB.Lock AlphaRect, BD, DDLOCK_WAIT, 0
bB.GetLockedArray ar()
DoEvents
clr = Rnd * 255
For y = 0 To (AlphaRect.bottom - 1)
For x = 0 To (AlphaRect.Right - 1) * 2
If ar(x, y) <> 0 And ar(x, y) <> 64 And ar(x, y) <> 255 And ar(x, y) <> 127 Then
If ar(x, y) = 224 Then
ar(x, y) = clr
End If
End If
Next
DoEvents
Next
DoEvents
bB.Unlock AlphaRect
GetWindowRect frmMain.mnCan.hwnd, DR
DDS.Blt DR, bB, BBR, DDBLT_WAIT
Case 1
tmpR.Top = Rnd * 200
tmpR.Left = Rnd * 50
bB.Blt BBR, Sprites(Index), SpriteR(Index), DDBLT_WAIT
bB.BltFast tmpR.Left, tmpR.Top, Sprites(6), SpriteR(6), DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
GetWindowRect frmMain.mnCan.hwnd, DR
DDS.Blt DR, bB, BBR, DDBLT_WAIT
Sleep 50
Case 2
On Error Resume Next
Dim nColor As Integer, tmp As Integer
bB.Blt BBR, Sprites(Index), SpriteR(Index), DDBLT_WAIT
GetWindowRect frmMain.mnCan.hwnd, DR
bB.Lock AlphaRect, BD, DDLOCK_WAIT, 0
bB.GetLockedArray ar()
DoEvents
nColor = Rnd * 256
If nColor = 0 Then nColor = 1
For y = 0 To (AlphaRect.bottom - 1)
For x = 0 To (AlphaRect.Right - 1) * (lPixelDepth \ 8)
If ar(x, y) <> 0 And ar(x, y) <> 124 Then
ar(x, y) = nColor
End If
Next
DoEvents
Next
DoEvents
bB.Unlock AlphaRect
DDS.Blt DR, bB, BBR, DDBLT_WAIT
On Error GoTo 0
Case 3
With fi(0)
.x = .x + 1: If .x > frmMain.mnCan.ScaleWidth Then .x = 0
.y = Sin(.x / 5) * 5 + (frmMain.mnCan.ScaleHeight \ 2)
End With
With fi(1)
.x = .x + 2: If .x > frmMain.mnCan.ScaleWidth Then .x = 0
.y = Sin(.x / 20) * 20 + (frmMain.mnCan.ScaleHeight \ 4)
End With
With fi(2)
.x = .x - 2: If .x < frmMain.mnCan.ScaleLeft Then .x = frmMain.mnCan.ScaleWidth
.y = Sin(.x / 40) * 40 + (frmMain.mnCan.ScaleHeight \ 3)
End With
Dim i As Integer
bB.BltColorFill BBR, &H0
For i = 0 To UBound(fi)
bB.BltFast fi(i).x, fi(i).y, Fish(i), fishR(i), DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
Next i
GetWindowRect frmMain.mnCan.hwnd, DR
DDS.Blt DR, bB, BBR, DDBLT_WAIT
Sleep 50
Case 5
Dim rSprite As DxVBLib.RECT
currentframe = currentframe + 1
If currentframe > rows * cols - 1 Then currentframe = 0
col = currentframe Mod cols
row = Int(currentframe / cols)
rSprite.Left = col * spriteWidth
rSprite.Top = row * spriteHeight
rSprite.Right = rSprite.Left + spriteWidth
rSprite.bottom = rSprite.Top + spriteHeight
bB.BltColorFill BBR, &H0
Set bB = MoveBackRight(bB, Sprites(9), slide)
DoEvents
bB.BltFast 0, frmMain.mnCan.ScaleHeight \ 3, Sprites(Index), rSprite, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
GetWindowRect frmMain.mnCan.hwnd, DR
DDS.Blt DR, bB, BBR, DDBLT_WAIT
Sleep 80
Case 6
bB.Blt BBR, Sprites(8), SpriteR(8), DDBLT_WAIT
bB.Lock AlphaRect, BD, DDLOCK_WAIT, 0
bB.GetLockedArray ar()
DoEvents
For y = 0 To (AlphaRect.bottom - 1)
For x = 0 To (AlphaRect.Right - 1) * 2
If ar(x, y) <> 0 And ar(x, y) <> 255 Then
ar(x, y) = Rnd * 255
End If
Next
DoEvents
Next
DoEvents
bB.Unlock AlphaRect
DDS.Blt DR, bB, BBR, DDBLT_WAIT
GetWindowRect frmMain.mnCan.hwnd, DR
DDS.Blt DR, bB, BBR, DDBLT_WAIT
' Sleep 20
End Select
Exit Sub
err_:
If Not (DD Is Nothing) Then
DD.SetCooperativeLevel frmMain.hwnd, DDSCL_NORMAL
DoEvents
End If
MsgBox "There was an issue with playing the current frame." & vbCrLf & _
Err.Number & vbCrLf & _
Err.Description, vbApplicationModal
End
End Sub
Public Sub StripVert(cChop() As DxVBLib.RECT, wD As Long, hD As Long)
Dim cntr As Integer
Dim nN As Long
Dim sZ As Long
For cntr = 0 To UBound(cChop)
sZ = wD / UBound(cChop)
nN = nN + sZ
cChop(cntr).Left = (nN - sZ)
cChop(cntr).Right = nN
cChop(cntr).bottom = hD
Next
'StripVert = cChop
End Sub
Public Function MoveBackRight(ByVal bB As DirectDrawSurface7, ByVal backgrounds As DirectDrawSurface7, recArray() As DxVBLib.RECT) As DirectDrawSurface7
Dim tmpC As Integer
Dim stp As Integer
Static cntrFR As Integer
For tmpC = 0 To UBound(recArray)
If cntrFR >= (UBound(recArray) - 1) Then
cntrFR = 0
End If
bB.BltFast recArray(cntrFR).Left, (frmMain.mnCan.ScaleHeight \ 3), backgrounds, recArray(tmpC), DDBLTFAST_WAIT
cntrFR = cntrFR + 1
DoEvents
Next
Set MoveBackRight = bB
DoEvents
End Function
Public Function LoadMSg(Index As Integer) As String
Dim tempMSG(7) As String
'wed
tempMSG(0) = "Big Band!" & vbCrLf & _
"Join us for a blast from the past! Enjoy cutting the rug " & vbCrLf & _
"with the finest big band musicians from the area. Whether " & vbCrLf & _
"you want to swing dance the night away, or just listen to " & vbCrLf & _
"the big sound from the stage, you're sure to have a great time." & vbCrLf & _
"Just don't forget the zoot suit at home!"
'thur
tempMSG(1) = "Jazz Night!" & vbCrLf & _
"Thursdays are a big night at Club Met, because our jazz music" & vbCrLf & _
"is always cool and fresh. The musicians that join us are always" & vbCrLf & _
"Grade A, including local band Benny HaHa and the Blue Wave." & vbCrLf & _
"Jazz has never been better!"
'fri
tempMSG(2) = "Disco!" & vbCrLf & _
"If the 70's are making a comeback, you'll find Friday Night at Club Met" & vbCrLf & _
"to be the headquarters. Always a blast, we bring in some of the original" & vbCrLf & _
"disco artists to play their most popular numbers. It's even more fun to" & vbCrLf & _
"come dressed to the part. Come once and it's sure to be your Friday Night" & vbCrLf & _
"hang out!"
'sat
tempMSG(3) = "Dance Night!" & vbCrLf & _
"A definite favorite of Generation X (and Y) is Dance night at Club Met." & vbCrLf & _
"Our own DJ, Flavor Mike, spins the latest dance hits all night long." & vbCrLf & _
"Once you start dancing, you can't slow down. Plenty of new people to " & vbCrLf & _
"meet, and always a good time."
'sun
tempMSG(4) = "Classical!" & vbCrLf & _
"If your tastes are more refined, we encourage you to join us on Sunday" & vbCrLf & _
"night at Club Met. You'll enjoy intellectual conversation and delightful" & vbCrLf & _
"music from the Baroque, Classical, and Romantic eras, played by renowned" & vbCrLf & _
"local artists. A great way to energize yourself for the week ahead."
LoadMSg = tempMSG(Index)
End Function

View File

@@ -0,0 +1,38 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#stdole2.tlb#OLE Automation
Reference=*\G{E1211242-8E94-11D1-8808-00C04FC2C603}#1.0#0#dx8vb.dll#DirectX 8 for Visual Basic Type Library
Reference=*\G{E1211242-8E94-11D1-8808-00C04FC2C602}#1.0#0#dx7vb.dll#DirectX 7 for Visual Basic Type Library
Form=ClubMet.frm
Module=basDD; basDD.bas
ResFile32="ClubMet.RES"
Module=MediaDir; ..\..\common\media.bas
IconForm="frmMain"
Startup="frmMain"
HelpFile=""
Title="ClubMet"
Command32=""
Name="vbClubMet"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="MS"
CondComp="RunInIDE = 0"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1