Tile Engine (tiler,res change,wav & midi player)

Sub ChangeRes(iWidth As Single, iHeight As Single)
'Just Call Changeres(1600,1200) or whatever you want in load
 Dim a As Boolean
 Dim i&
 i = 0
 Do
 a = EnumDisplaySettings(0&, i&, DevM)
 i = i + 1
 Loop Until (a = False)
 Dim b&
 DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
 DevM.dmPelsWidth = iWidth
 DevM.dmPelsHeight = iHeight
 b = ChangeDisplaySettings(DevM, 0)
End Sub
Public Sub TilePicture(frmDest As Form, source As PictureBox, X, Y)
'This is not the sub that you want to use, it may be a good one to modify though
'If you think you need Direct-X or just want to see what will work.
 Dim pw As Integer
 Dim ph As Integer
 Dim fw As Integer
 Dim fh As Integer
 Dim rst As Integer
 source.ScaleMode = 3
 pw = source.ScaleWidth
 ph = source.ScaleHeight
 fw = frmDest.Width / Screen.TwipsPerPixelX
 fh = frmDest.Height / Screen.TwipsPerPixelY
iResult = BitBlt(frmDest.hdc, X, Y, iPicWidth, iPicHeight, picSource.hdc, 0, 0, vbSrcCopy)
End Sub
Public Sub LoadMap(InvisText As TextBox, mapname As String)
'maps constists of numbers like
'
'00012301
'12321455
'51000102
'and so forth, if anyone wants to make a map editor, that would be cool,
'but I don't got the time(5:00 - 9:00pm) in football practice
 Dim lFileLength As Long
 Dim iFileNum As Integer
 iFileNum = FreeFile
 Open mapname For Input As iFileNum
 lFileLength = LOF(iFileNum)
 Text1.Text = Input(lFileLength, #iFileNum)
 Close iFileNum
End Sub
Public Sub OpenMidi()
'dont call this, it needs a few mods
 Dim sFile As String
 Dim sShortFile As String * 67
 Dim lResult As Long
 Dim sError As String * 255
 sFile = App.Path & "\midtest.mid"
 lResult = GetShortPathName(sFile, sShortFile, Len(sShortFile))
 sFile = Left$(sShortFile, lResult)
 lResult = mciSendString("open " & sFile & _
 " type sequencer alias mcitest", ByVal 0&, 0, 0)
 If lResult Then
 lResult = mciGetErrorString(lResult, sError, 255)
 Debug.Print "open: " & sError
 End If
End Sub
Public Sub PlayMidi()
'see above
 Dim lResult As Integer
 Dim sError As String * 255
 lResult = mciSendString("play mcitest", ByVal 0&, 0, 0)
 If lResult Then
 lResult = mciGetErrorString(lResult, sError, 255)
 Debug.Print "play: " & sError
 End If
End Sub
Public Sub CloseMidi()
'again see above, i am sorry I will update soon
 Dim lResult As Integer
 Dim sError As String * 255
 lResult = mciSendString("close mcitest", "", 0&, 0&)
 If lResult Then
 lResult = mciGetErrorString(lResult, sError, 255)
 Debug.Print "stop: " & sError
 End If
End Sub
Sub PlayWave(sFileName As String)
 On Error GoTo Play_Err
 Dim iReturn As Integer
 If sFileName > "" Then
 If UCase$(Right$(sFileName, 3)) = "WAV" Then
  If Dir(sFileName) > "" Then
  iReturn = sndPlaySound(sFileName, 0)
  End If
 End If
 End If
 Exit Sub
Play_Err:
 Exit Sub
End Sub
Function TileWalkable(Tilesize As Integer, LoadedMap As TextBox, X As Integer, Y As Integer, LineWidth As Integer) As Boolean
'Funky Tile Engine Note:
'Most pic boxes use twip, so divide pic.width by screen.twipsperpixelx and same for height, execpt for y insted.
'I also suggest that you modify this if you are tring to make a more customized
'engine, because this at this time gives you 18 unwalkables
Dim xx As Integer
Dim yy As Integer
Dim temp As Integer
Dim a As String
Dim b As String
xx = X / Tilesize
yy = Y / Tilesize
If Y < Tilesize Then
 a = Left(LoadedMap, xx)
 b = Mid(a, xx, 1): GoTo 1
End If
temp = yy * LineWidth + 2
a = Left(LoadedMap, xx + temp)
b = Mid(a, xx + temp, 1): GoTo 1
1
MsgBox b
If b = "0" Then TileWalkable = False: Exit Function
If b = "1" Then TileWalkable = False: Exit Function
If b = "2" Then TileWalkable = False: Exit Function
If b = "3" Then TileWalkable = False: Exit Function
If b = "4" Then TileWalkable = False: Exit Function
If b = "5" Then TileWalkable = False: Exit Function
If b = "6" Then TileWalkable = False: Exit Function
If b = "7" Then TileWalkable = False: Exit Function
If b = "8" Then TileWalkable = False: Exit Function
If b = "9" Then TileWalkable = False: Exit Function
If b = "a" Then TileWalkable = False: Exit Function
If b = "b" Then TileWalkable = False: Exit Function
If b = "c" Then TileWalkable = False: Exit Function
If b = "d" Then TileWalkable = False: Exit Function
If b = "e" Then TileWalkable = False: Exit Function
If b = "f" Then TileWalkable = False: Exit Function
If b = "g" Then TileWalkable = False: Exit Function
TileWalkable = True
End Function
Sub Tilemake(LoadedMap As TextBox, MapXLength As Integer, MapYLength, PicWidth As Integer, Dest As Form, Optional pic0 As PictureBox, Optional pic1 As PictureBox, Optional pic2 As PictureBox, Optional pic3 As PictureBox, Optional pic4 As PictureBox, Optional pic5 As PictureBox, Optional pic6 As PictureBox, Optional pic7 As PictureBox, Optional pic8 As PictureBox, Optional pic9 As PictureBox, Optional pic10 As PictureBox, Optional pic11 As PictureBox, Optional pic12 As PictureBox, Optional pic13 As PictureBox, Optional pic14 As PictureBox, Optional pic15 As PictureBox, Optional pic16 As PictureBox, Optional pic17 As PictureBox, Optional pic18 As PictureBox, Optional pic19 As PictureBox, Optional pic20 As PictureBox, Optional pic21 As PictureBox, Optional pic22 As PictureBox, Optional pic23 As PictureBox, Optional pic24 As PictureBox, Optional pic25 As PictureBox, Optional pic26 As PictureBox, Optional pic27 As PictureBox, Optional pic28 As PictureBox, Optional pic29 As PictureBox, _
Optional pic30 As PictureBox, Optional pic31 As PictureBox, Optional pic32 As PictureBox, Optional pic33, Optional pic34 As PictureBox, Optional pic35 As PictureBox)
'this is what you call
'all pictureboxes are optional, so you don't have to use them all
'Put me in the form paint
'after 0123456789 comes a - z
'be creative if you want more, ~!@#$%^&*()_+
cc = 0
aa = 0
bb = 0
1
For i = 0 To MapXLength
a = Mid(LoadedMap, i + aa + 1, 1)
dd = i * PicWidth
dd = dd + 224
If a = "0" Then Call TilePicture(Dest, pic0, dd, cc)
If a = "1" Then Call TilePicture(Dest, pic1, dd, cc)
If a = "2" Then Call TilePicture(Dest, pic2, dd, cc)
If a = "3" Then Call TilePicture(Dest, pic3, dd, cc)
If a = "4" Then Call TilePicture(Dest, pic4, dd, cc)
If a = "5" Then Call TilePicture(Dest, pic5, dd, cc)
If a = "6" Then Call TilePicture(Dest, pic6, dd, cc)
If a = "7" Then Call TilePicture(Dest, pic7, dd, cc)
If a = "8" Then Call TilePicture(Dest, pic8, dd, cc)
If a = "9" Then Call TilePicture(Dest, pic9, dd, cc)
If a = "a" Then Call TilePicture(Dest, pic10, dd, cc)
If a = "b" Then Call TilePicture(Dest, pic11, dd, cc)
If a = "c" Then Call TilePicture(Dest, pic12, dd, cc)
If a = "d" Then Call TilePicture(Dest, pic13, dd, cc)
If a = "e" Then Call TilePicture(Dest, pic14, dd, cc)
If a = "f" Then Call TilePicture(Dest, pic15, dd, cc)
If a = "g" Then Call TilePicture(Dest, pic16, dd, cc)
If a = "h" Then Call TilePicture(Dest, pic17, dd, cc)
If a = "i" Then Call TilePicture(Dest, pic18, dd, cc)
If a = "j" Then Call TilePicture(Dest, pic19, dd, cc)
If a = "k" Then Call TilePicture(Dest, pic20, dd, cc)
If a = "l" Then Call TilePicture(Dest, pic21, dd, cc)
If a = "m" Then Call TilePicture(Dest, pic22, dd, cc)
If a = "n" Then Call TilePicture(Dest, pic23, dd, cc)
If a = "o" Then Call TilePicture(Dest, pic24, dd, cc)
If a = "p" Then Call TilePicture(Dest, pic25, dd, cc)
If a = "q" Then Call TilePicture(Dest, pic26, dd, cc)
If a = "r" Then Call TilePicture(Dest, pic27, dd, cc)
If a = "s" Then Call TilePicture(Dest, pic28, dd, cc)
If a = "t" Then Call TilePicture(Dest, pic29, dd, cc)
If a = "u" Then Call TilePicture(Dest, pic30, dd, cc)
If a = "v" Then Call TilePicture(Dest, pic31, dd, cc)
If a = "w" Then Call TilePicture(Dest, pic32, dd, cc)
'If a = "x" Then Call TilePicture(Dest, pic33, dd, cc)
'If a = "y" Then Call TilePicture(Dest, pic34, dd, cc)
'If a = "z" Then Call TilePicture(Dest, pic35, dd, cc)
Next i
cc = cc + PicWidth
aa = aa + MapXLength + 2
bb = bb + 1
If bb > MapYLength Then Exit Sub
GoTo 1
End Sub
'Private Sub TransparentBlt(OutDstDC As Long, DstDC As Long, SrcDC As Long, SrcRect As RECT, DstX As Integer, DstY As Integer, TransColor As Long)
' Dim nRet As Long, W As Integer, H As Integer
' Dim MonoMaskDC As Long, hMonoMask As Long
' Dim MonoInvDC As Long, hMonoInv As Long
' Dim ResultDstDC As Long, hResultDst As Long
' Dim ResultSrcDC As Long, hResultSrc As Long
' Dim hPrevMask As Long, hPrevInv As Long
' Dim hPrevSrc As Long, hPrevDst As Long
' W = SrcRect.Right - SrcRect.Left + 1
' H = SrcRect.Bottom - SrcRect.Top + 1
' MonoMaskDC = CreateCompatibleDC(DstDC)
' MonoInvDC = CreateCompatibleDC(DstDC)
' hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
' hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
' hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
' hPrevInv = SelectObject(MonoInvDC, hMonoInv)
' ResultDstDC = CreateCompatibleDC(DstDC)
' ResultSrcDC = CreateCompatibleDC(DstDC)
' hResultDst = CreateCompatibleBitmap(DstDC, W, H)
' hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
' hPrevDst = SelectObject(ResultDstDC, hResultDst)
' hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
' Dim OldBC As Long
' OldBC = SetBkColor(SrcDC, TransColor)
' nRet = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)
' TransColor = SetBkColor(SrcDC, OldBC)
' nRet = BitBlt(MonoInvDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbNotSrcCopy)
' nRet = BitBlt(ResultDstDC, 0, 0, W, H, DstDC, DstX, DstY, vbSrcCopy)
' nRet = BitBlt(ResultDstDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbSrcAnd)
' nRet = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)
' nRet = BitBlt(ResultSrcDC, 0, 0, W, H, MonoInvDC, 0, 0, vbSrcAnd)
' nRet = BitBlt(ResultDstDC, 0, 0, W, H, ResultSrcDC, 0, 0, vbSrcInvert)
' nRet = BitBlt(OutDstDC, DstX, DstY, W, H, ResultDstDC, 0, 0, vbSrcCopy)
' hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
' DeleteObject hMonoMask
' hMonoInv = SelectObject(MonoInvDC, hPrevInv)
' DeleteObject hMonoInv
' hResultDst = SelectObject(ResultDstDC, hPrevDst)
' DeleteObject hResultDst
' hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
' DeleteObject hResultSrc
' DeleteDC MonoMaskDC
' DeleteDC MonoInvDC
' DeleteDC ResultDstDC
' DeleteDC ResultSrcDC
'End Sub
'Dim R As RECT
' With R
' .Left = 0
' .Top = 0
' .Right = Picture1.ScaleWidth
' .Bottom = Picture1.ScaleHeight
'End With
'
'TransparentBlt Form1.hDC, Form1.hDC, Picture1.hDC, R, 20, 20, vbblack