home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Drablo_Map1969091312006.psc / Form1.frm < prev    next >
Text File  |  2006-01-31  |  8KB  |  273 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Drablo map engine"
  5.    ClientHeight    =   5025
  6.    ClientLeft      =   45
  7.    ClientTop       =   330
  8.    ClientWidth     =   5010
  9.    Icon            =   "Form1.frx":0000
  10.    LinkTopic       =   "Form1"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   335
  14.    ScaleMode       =   3  'Pixel
  15.    ScaleWidth      =   334
  16.    StartUpPosition =   3  'Windows Default
  17.    Begin VB.Timer timWalk 
  18.       Enabled         =   0   'False
  19.       Interval        =   100
  20.       Left            =   3360
  21.       Top             =   3720
  22.    End
  23.    Begin VB.PictureBox picMChar 
  24.       Appearance      =   0  'Flat
  25.       AutoRedraw      =   -1  'True
  26.       AutoSize        =   -1  'True
  27.       BackColor       =   &H80000005&
  28.       ForeColor       =   &H80000008&
  29.       Height          =   255
  30.       Left            =   360
  31.       ScaleHeight     =   15
  32.       ScaleMode       =   3  'Pixel
  33.       ScaleWidth      =   15
  34.       TabIndex        =   3
  35.       Top             =   120
  36.       Visible         =   0   'False
  37.       Width           =   255
  38.    End
  39.    Begin VB.PictureBox picChar 
  40.       Appearance      =   0  'Flat
  41.       AutoRedraw      =   -1  'True
  42.       AutoSize        =   -1  'True
  43.       BackColor       =   &H80000005&
  44.       ForeColor       =   &H80000008&
  45.       Height          =   255
  46.       Left            =   240
  47.       ScaleHeight     =   15
  48.       ScaleMode       =   3  'Pixel
  49.       ScaleWidth      =   15
  50.       TabIndex        =   2
  51.       Top             =   120
  52.       Visible         =   0   'False
  53.       Width           =   255
  54.    End
  55.    Begin VB.PictureBox picTiles 
  56.       Appearance      =   0  'Flat
  57.       AutoRedraw      =   -1  'True
  58.       AutoSize        =   -1  'True
  59.       BackColor       =   &H80000005&
  60.       ForeColor       =   &H80000008&
  61.       Height          =   255
  62.       Left            =   120
  63.       ScaleHeight     =   15
  64.       ScaleMode       =   3  'Pixel
  65.       ScaleWidth      =   15
  66.       TabIndex        =   0
  67.       Top             =   120
  68.       Visible         =   0   'False
  69.       Width           =   255
  70.    End
  71.    Begin VB.PictureBox picSight 
  72.       AutoRedraw      =   -1  'True
  73.       BackColor       =   &H00000000&
  74.       FontTransparent =   0   'False
  75.       Height          =   4800
  76.       Left            =   120
  77.       ScaleHeight     =   316
  78.       ScaleMode       =   3  'Pixel
  79.       ScaleWidth      =   316
  80.       TabIndex        =   1
  81.       Top             =   120
  82.       Width           =   4800
  83.    End
  84. End
  85. Attribute VB_Name = "frmMain"
  86. Attribute VB_GlobalNameSpace = False
  87. Attribute VB_Creatable = False
  88. Attribute VB_PredeclaredId = True
  89. Attribute VB_Exposed = False
  90. 'Author: Wiktor Toporek
  91. 'Contact:
  92. 'mail: witek1@konto.pl
  93. '   or wtoporek@gmail.com
  94.  
  95.  
  96. Dim Sector() As Integer
  97. Dim MapName As String
  98. Dim PlayerX As Single, PlayerY As Single
  99. Const TCols As Integer = 8
  100. Const SecSize As Integer = 32
  101. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  102. Dim col(0 To 255) As Boolean
  103. Dim ChangeLeg As Boolean
  104. Dim PlayerSide As Integer
  105. Dim LastKey As Integer
  106.  
  107.  
  108. Private Sub Form_Load()
  109.     picTiles.Picture = LoadPicture(App.Path & "\s02tiles.bmp")
  110.     
  111.     picChar.Picture = LoadPicture(App.Path & "\char.bmp")
  112.     picMChar.Picture = LoadPicture(App.Path & "\charmask.gif") 'Maska postaci
  113.     
  114.     LoadCollisionSet "Collision.dat"
  115.     
  116.     LoadMap "Las1"
  117.  
  118.     timWalk_Timer
  119. End Sub
  120.  
  121.  
  122. Public Sub LoadCollisionSet(File As String)
  123.     Dim FN As Integer
  124.     Dim Linia As String
  125.     Dim Z As Integer
  126.     
  127.     FN = FreeFile
  128.     Open App.Path & "\" & File For Input As #FN
  129.         Line Input #FN, Linia
  130.         For Z = 1 To Len(Linia)
  131.             col(Z - 1) = CBool(Mid(Linia, Z, 1))
  132.         Next
  133.     Close FN
  134.     
  135.     
  136. End Sub
  137.  
  138.  
  139.  
  140. Public Sub RefreshCamera()
  141.  
  142.     On Error Resume Next
  143.     Dim X As Integer, Y As Integer
  144.     Dim SecW As Integer, SecH As Integer
  145.     Dim CX As Integer, CY As Integer
  146.     Dim PX As Integer, PY As Integer
  147.     
  148.     SecW = CInt(picSight.ScaleWidth / SecSize)
  149.     SecH = CInt(picSight.ScaleHeight / SecSize)
  150.     picSight.Cls
  151.     
  152.  
  153.     For Y = Int(PlayerY / SecSize) - Int(SecH / 2) To Int(PlayerY / SecSize) + Int(SecH / 2)
  154.         For X = Int(PlayerX / SecSize) - Int(SecW / 2) To Int(PlayerX / SecSize) + Int(SecW / 2)
  155.             If X > -1 And Y > -1 And X <= UBound(Sector, 1) And Y <= UBound(Sector, 2) Then
  156.                 CX = 1
  157.                 CY = 0
  158.                 CY = Int(Sector(X, Y) / TCols)
  159.                 CX = Sector(X, Y) - (Fix(Sector(X, Y) / TCols) * TCols)
  160.                 If Not (CX = 1 And CY = 0) Then
  161.                     PX = Int(SecW / 2) * SecSize - PlayerX + X * SecSize
  162.                     PY = Int(SecH / 2) * SecSize - PlayerY + Y * SecSize
  163.                     BitBlt picSight.hDC, PX, PY, SecSize, SecSize, picTiles.hDC, CX * SecSize, CY * SecSize, vbSrcCopy
  164.                 End If
  165.             End If
  166.         Next
  167.     Next
  168.     
  169.  
  170.     BitBlt picSight.hDC, picSight.ScaleWidth / 2 - 16, picSight.ScaleHeight / 2 - 16, 32, 32, picMChar.hDC, 32 * Abs(ChangeLeg), PlayerSide * 32, vbMergePaint
  171.     BitBlt picSight.hDC, picSight.ScaleWidth / 2 - 16, picSight.ScaleHeight / 2 - 16, 32, 32, picChar.hDC, 32 * Abs(ChangeLeg), PlayerSide * 32, vbSrcAnd
  172.  
  173.  
  174. End Sub
  175.  
  176. Public Sub LoadMap(File As String)
  177.     Dim Linia As String
  178.     Dim arg As Variant
  179.     Dim X As Integer, Y As Integer
  180.     Dim FN As Integer
  181.     
  182.     
  183.  
  184.     Erase Sector
  185.     
  186.     FN = FreeFile
  187.     
  188.  
  189.     Open App.Path & "\" & File & ".map" For Input As FN
  190.         
  191.  
  192.         Line Input #FN, Linia
  193.         arg = Split(Linia, "||")
  194.         MapName = CStr(arg(0))
  195.         ReDim Sector(0 To CInt(arg(1)), 0 To CInt(arg(2)))
  196.         
  197.         'Pozycja startowa gracza:
  198.         PlayerX = CSng(arg(3) * 32 + 16)
  199.         PlayerY = CSng(arg(4) * 32 + 16)
  200.         
  201.         Do While Not EOF(FN)
  202.             Line Input #FN, Linia
  203.             If Linia <> "" Then
  204.                 For X = 0 To Len(Linia) - 1
  205.                     Sector(X, Y) = CInt(255 - Asc(Mid(Linia, X + 1, 1))) 'Po sektorze do tablicy
  206.                 Next
  207.                 Y = Y + 1
  208.             End If
  209.         Loop
  210.     Close FN
  211.  
  212. End Sub
  213.  
  214. Private Sub picSight_KeyDown(KeyCode As Integer, Shift As Integer)
  215.     LastKey = KeyCode
  216.     timWalk.Enabled = True
  217. End Sub
  218.  
  219.  
  220. Private Sub picSight_KeyUp(KeyCode As Integer, Shift As Integer)
  221.     timWalk.Enabled = False
  222. End Sub
  223.  
  224. Private Sub timWalk_Timer()
  225.     On Error Resume Next
  226.     Dim NewX As Single, NewY As Single
  227.     
  228.     Select Case LastKey
  229.         Case vbKeyLeft
  230.             NewX = PlayerX - 8
  231.             
  232.             If Not col(Sector(CInt((NewX - SecSize / 2) / SecSize), Int(PlayerY / SecSize))) Then
  233.                 PlayerX = NewX
  234.                 PlayerSide = 3
  235.                 ChangeLeg = True - ChangeLeg
  236.             End If
  237.  
  238.         Case vbKeyUp
  239.             NewY = PlayerY - 8
  240.             
  241.             If Not col(Sector(CInt((PlayerX - SecSize / 2) / SecSize), Int(NewY / SecSize))) Then
  242.                 PlayerY = NewY
  243.                 PlayerSide = 0
  244.                 ChangeLeg = True - ChangeLeg
  245.             End If
  246.         Case vbKeyRight
  247.             NewX = PlayerX + 8
  248.             
  249.             If Not col(Sector(CInt((NewX - SecSize / 2) / SecSize), Int(PlayerY / SecSize))) Then
  250.                 PlayerX = NewX
  251.                 PlayerSide = 1
  252.                 ChangeLeg = True - ChangeLeg
  253.             End If
  254.         Case vbKeyDown
  255.             NewY = PlayerY + 8
  256.             
  257.             If Not col(Sector(CInt((PlayerX - SecSize / 2) / SecSize), Int(NewY / SecSize))) Then
  258.                 PlayerY = NewY
  259.                 PlayerSide = 2
  260.                 ChangeLeg = True - ChangeLeg
  261.             End If
  262.     End Select
  263.  
  264.     RefreshCamera
  265.     
  266.     
  267.     picSight.ForeColor = vbRed
  268.     picSight.Print "Map name: " & MapName
  269.     picSight.Print "Player position: (" & PlayerX & ", " & PlayerY & ")"
  270.     picSight.Print "Player sector: (" & Int(PlayerX / 32) & ", " & Int(PlayerY / 32) & ")"
  271.     
  272. End Sub
  273.