home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD8755882000.psc / modMain.bas < prev    next >
Encoding:
BASIC Source File  |  2000-08-09  |  3.9 KB  |  118 lines
  1. Attribute VB_Name = "modMain"
  2. Private Declare Sub ReleaseCapture Lib "user32" ()
  3. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  4.  
  5. Public Function EnumFilesByExt(Path As String, ListBox As ListBox, Extension As String)
  6. ListBox.Clear
  7.     Dim XDir() As String
  8.     Dim TmpDir As String
  9.     If Right(Path, 1) <> "\" Then
  10.         Path = Path & "\"
  11.     End If
  12.  
  13.  
  14.     DoEvents
  15.         TmpDir = Dir(Path, vbDirectory + vbHidden + vbSystem + vbArchive + vbReadOnly)
  16.  
  17.  
  18.         Do While TmpDir <> ""
  19.  
  20.  
  21.             If TmpDir <> "." And TmpDir <> ".." Then
  22.  
  23.  
  24.                 If (GetAttr(Path & TmpDir)) <> vbDirectory Then
  25.                     If Right(TmpDir, Len(Extension)) = Extension Then ListBox.AddItem TmpDir
  26.                     ReDim Preserve XDir(DirCount) As String
  27.                 End If
  28.             End If
  29.             TmpDir = Dir
  30.             
  31.         Loop
  32. End Function
  33.  
  34. Public Sub MoveForm(Form As Form)
  35.     ReleaseCapture
  36.     Call SendMessage(Form.hwnd, &HA1, 2, 0&)
  37. End Sub
  38.  
  39. Public Sub SaveFile(Filename As String, Text As String)
  40. On Error GoTo ErrorHandler
  41.     FileNumber = FreeFile
  42.     Open Filename For Binary As FileNumber Len = Len(Text)
  43.     Put #FileNumber, , Text
  44.     Close FileNumber
  45. ErrorHandler:
  46.         If Err.Number <> 0 Then
  47.             Exit Sub
  48.         End If
  49. End Sub
  50.  
  51. Function OpenFile(Filename As String, TextBox As TextBox)
  52. On Error Resume Next
  53.     Open Filename For Binary As #1
  54.     TextBox.Text = Input(LOF(1), #1)
  55.     Close #1
  56. End Function
  57.  
  58. 'Gets character level
  59. Function GetLevel(SaveFile As String) As String
  60.     Dim vRetVal, nLVL As Integer, lPos As Long
  61.     lPos = 37 'The position where the value stands
  62.     Open SaveFile For Binary As #1  'open a save file as binary
  63.     Get #1, lPos, nLVL 'Now, get the value
  64.     Close #1   'Close the file
  65.     vRetVal = Hex(nLVL)
  66.     vRetVal = "&H" & CStr(vRetVal) 'convert it to a vb hex value because the clng function does not know the diffrence between a number and a hex without the &H
  67.     If vRetVal = 0 Then
  68.         GetLevel = "1" 'Get the level, and we're all done ! :-)
  69.     Else
  70.         GetLevel = CStr(CLng(vRetVal)) 'Get the level, and we're all done ! :-)
  71.     End If
  72. End Function
  73.  
  74. 'Gets character's status (title)
  75. Function GetStatus(SaveFile As String) As String
  76.     Dim nStatus As Integer, str As String
  77.     Open SaveFile For Binary As #1  'open a save file a binary
  78.     Get #1, 26, nStatus 'now, get the value
  79.     Close #1   'close the file
  80.     str = GetClass(SaveFile)
  81.     If str = "Barbarian" Then GoTo SetMan
  82.     If str = "Necromancer" Then GoTo SetMan
  83.     If str = "Paladin" Then GoTo SetMan
  84.     If str = "Amazon" Then GoTo SetWomen
  85.     If str = "Sorceress" Then GoTo SetWomen
  86. SetMan:         If Hex(nStatus) = 7 Then GetStatus = "Sir"
  87.                 If Hex(nStatus) = 5 Then GetStatus = "Sir"
  88.                 If Hex(nStatus) = 9 Then GetStatus = "Lord"
  89.                 If CStr(Hex(nStatus)) = "C" Then GetStatus = "Baron"
  90.                 Exit Function
  91. SetWomen:   If Hex(nStatus) = 7 Then GetStatus = "Dame"
  92.             If Hex(nStatus) = 5 Then GetStatus = "Dame"
  93.             If Hex(nStatus) = 9 Then GetStatus = "Lady"
  94.             If CStr(Hex(nStatus)) = "C" Then GetStatus = "Baroness"
  95.     If Hex(nStatus) = 0 Then GetStatus = "" 'None (Not killed Diablo yet)
  96. End Function
  97.  
  98. 'Gets the character class out of a save file
  99. Function GetClass(SaveFile As String) As String
  100.     Dim vRetVal As Integer, nClass As Integer
  101.     Open SaveFile For Binary As #1  'open a save file as binary
  102.     Get #1, 35, nClass 'now, get the value
  103.     Close #1   'close the file
  104.     Select Case nClass 'Returned cases:
  105.     Case 0
  106.         GetClass = "Amazon"
  107.     Case 1
  108.         GetClass = "Sorceress"
  109.     Case 2
  110.         GetClass = "Necromancer"
  111.     Case 3
  112.         GetClass = "Paladin"
  113.     Case 4
  114.         GetClass = "Barbarian"
  115.     End Select
  116. End Function
  117.  
  118.