home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / automa_1 / modmain.bas < prev    next >
Encoding:
BASIC Source File  |  1999-08-23  |  7.9 KB  |  237 lines
  1. Attribute VB_Name = "ModMain"
  2. Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
  3. Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
  4. Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
  5. Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
  6. Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  7. Declare Sub ReleaseCapture Lib "user32" ()
  8. Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
  9. Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  10. Const WarpStarSpeed = 100
  11. Type PointAPI
  12. x As Long
  13. y As Long
  14. End Type
  15. Type Stars
  16.     SpeedY As Integer
  17.     SpeedX As Integer
  18.     StarX As Integer
  19.     StarY As Integer
  20.     StarColor As Byte
  21. End Type
  22. Public SpecialEffectX As Integer
  23. Public SpecialEffectY As Integer
  24. Public Star() As Stars 'Array of Stars Type
  25. Public StarCount As Integer ' holds the amount of stars in array
  26. Public Status As String 'holds Name of the current effect
  27.  
  28.  
  29.  
  30. Private Function ConvertIPAddressToLong(strAddress As String) As Long
  31.  
  32.  
  33.     'For Ping: It changes the IP Address so it can be used to send th
  34.     '     e ping
  35.     On Error Resume Next
  36.     Dim strTemp As String
  37.     Dim lAddress As Long
  38.     Dim iValCount As Integer
  39.     Dim lDotValues(1 To 4) As String
  40.     strTemp = strAddress
  41.     iValCount = 0
  42.     While InStr(strTemp, ".") > 0
  43.         iValCount = iValCount + 1
  44.         lDotValues(iValCount) = Mid(strTemp, 1, InStr(strTemp, ".") - 1)
  45.         strTemp = Mid(strTemp, InStr(strTemp, ".") + 1)
  46.     Wend
  47.  
  48.  
  49.     iValCount = iValCount + 1
  50.     lDotValues(iValCount) = strTemp
  51.     If iValCount <> 4 Then
  52.         ConvertIPAddressToLong = 0
  53.         Exit Function
  54.     End If
  55.  
  56.  
  57.     lAddress = Val("&H" & Right("00" & Hex(lDotValues(4)), 2) & _
  58.     Right("00" & Hex(lDotValues(3)), 2) & _
  59.     Right("00" & Hex(lDotValues(2)), 2) & _
  60.     Right("00" & Hex(lDotValues(1)), 2))
  61.     ConvertIPAddressToLong = lAddress
  62. End Function
  63.  
  64. Public Sub FormDrag(TheForm As Form)
  65.  
  66.  
  67.     ReleaseCapture
  68.     Call SendMessage(TheForm.hwnd, &HA1, 2, 0&)
  69. End Sub
  70.  
  71. Sub ctr(ctr As PictureBox, frm As Form)
  72. ctr.Left = (frm.ScaleWidth - ctr.Width) / 2
  73. End Sub
  74.  
  75. Public Sub SaveListBox(TheList As ListBox, Directory As String)
  76.  
  77.  
  78.     Dim SaveList As Long
  79.     On Error Resume Next
  80.     Open Directory$ For Output As #1
  81.     For SaveList& = 0 To TheList.ListCount - 1
  82.         Print #1, TheList.List(SaveList&)
  83.     Next SaveList&
  84.  
  85.  
  86.     Close #1
  87. End Sub
  88. Public Function FileExists(strPath As String) As Integer
  89.  
  90.  
  91.     FileExists = Not (Dir(strPath) = "")
  92. End Function
  93.  
  94.  
  95. 'Example: Call LoadListBox(list1, "C:\Temp\MyList.dat")
  96. Public Sub LoadListBox(TheList As ListBox, Directory As String)
  97.  
  98.  
  99.     Dim MyString As String
  100.     On Error Resume Next
  101.     Open Directory$ For Input As #1
  102.     While Not EOF(1)
  103.         Input #1, MyString$
  104.         DoEvents
  105.             TheList.AddItem MyString$
  106.         Wend
  107.  
  108.  
  109.         Close #1
  110.         
  111.     End Sub
  112.  
  113.  
  114.  
  115. Sub ReDimStars(HowManyStars As Integer)
  116. 'call this to reset the amount of stars, MAX = 32,767
  117.   StarCount = HowManyStars
  118.   ReDim Star(0 To HowManyStars)
  119. End Sub
  120.  
  121.  
  122. Sub AddStars(NumberToAdd As Integer, WhatHeight As Integer, WhatWidth As Integer)
  123. 'call this to add more stars, MAX = 32,767
  124.   Dim NewAmount As Integer, Starloop As Integer
  125.   NewAmount = StarCount + NumberToAdd
  126.   ReDim Preserve Star(0 To NewAmount)
  127.   Select Case Status
  128.     Case "Snow"
  129.       For Starloop = StarCount To NewAmount
  130.         Star(Starloop).StarX = 0
  131.         Star(Starloop).StarX = Int(Rnd * WhatWidth)
  132.         Star(Starloop).StarColor = 15
  133.         Star(Starloop).SpeedY = Int(Rnd * 3) + 1
  134.       Next Starloop
  135.       StarCount = NewAmount
  136.   End Select
  137. End Sub
  138. Sub StarSetup(WhatHeight As Integer, WhatWidth As Integer)
  139.   Dim i As Integer, j As Integer
  140.   If StarCount = Null Or StarCount = 0 Then Exit Sub
  141.   Select Case Status
  142.         
  143.   Case "Snow"
  144.     For i = 0 To StarCount
  145.       Star(i).StarColor = 15
  146.       Star(i).StarX = Int(Rnd * WhatWidth)
  147.       Star(i).StarY = Int(Rnd * WhatHeight)
  148.       Star(i).SpeedY = Int(Rnd * 3) + 1
  149.     Next i
  150.   Case "Stars"
  151.     For i = 0 To StarCount
  152.       Star(i).StarColor = Int(Rnd * 15) + 1
  153.       Star(i).StarX = Int(Rnd * WhatWidth)
  154.       Star(i).StarY = Int(Rnd * WhatHeight)
  155.       Star(i).SpeedY = Int(Rnd * 7) + 1
  156.     Next i
  157.             
  158.   Case "Black Hole"
  159.     For i = 0 To StarCount
  160.       Star(i).StarColor = Int(Rnd * 15) + 1
  161.       Star(i).StarX = Int(WhatWidth / 2)
  162.       Star(i).StarY = Int(WhatHeight / 2)
  163.       Star(i).SpeedY = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  164.       Star(i).SpeedX = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  165.       Do While Star(i).SpeedX = 0 Or Star(i).SpeedY = 0
  166.         Randomize
  167.         Star(i).SpeedY = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  168.         Star(i).SpeedX = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  169.       Loop
  170.       For j = 0 To 30
  171.         NextStarPosition i, WhatWidth, WhatHeight
  172.       Next j
  173.       Next i
  174.   End Select
  175. End Sub
  176.  
  177.  
  178. Sub NextStarPosition(StarNumber As Integer, WhatHeight As Integer, WhatWidth As Integer)
  179.  
  180.   Select Case Status
  181.  
  182.     Case "Snow"
  183.       Star(StarNumber).StarY = Star(StarNumber).StarY + Star(StarNumber).SpeedY
  184.       Star(StarNumber).StarX = Star(StarNumber).StarX + Int(5 * Rnd) - 2
  185.       If Star(StarNumber).StarX > WhatWidth Then Star(StarNumber).StarX = 0
  186.       If Star(StarNumber).StarX < 0 Then Star(StarNumber).StarX = WhatWidth
  187.       If Star(StarNumber).StarY > WhatHeight Then
  188.         Star(StarNumber).SpeedY = Int(2 * Rnd) + 1
  189.         Star(StarNumber).StarY = Star(StarNumber).SpeedY
  190.         Star(StarNumber).StarColor = 15
  191.       End If
  192.     
  193.     Case "Stars"
  194.       Star(StarNumber).StarY = Star(StarNumber).StarY + Star(StarNumber).SpeedY
  195.       If Star(StarNumber).StarY > WhatHeight Then
  196.         Star(StarNumber).SpeedY = Int(7 * Rnd) + 2
  197.         Star(StarNumber).StarY = Star(StarNumber).SpeedY
  198.         Star(StarNumber).StarColor = Int(Rnd * 15) + 1
  199.       End If
  200.  
  201.     Case "Black Hole"
  202.       If Star(StarNumber).StarY > WhatHeight Or Star(StarNumber).StarX > WhatWidth Or Star(StarNumber).StarY < 0 Or Star(StarNumber).StarX < 0 Then
  203.         Star(StarNumber).StarX = SpecialEffectX 'Int(WhatWidth / 2) + SpecialEffectX
  204.         Star(StarNumber).StarY = SpecialEffectY 'Int(WhatHeight / 2) + SpecialEffectY
  205.         Randomize
  206.         Star(StarNumber).SpeedX = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  207.         Star(StarNumber).SpeedY = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  208.         Do While (Star(StarNumber).SpeedX = Star(StarNumber).SpeedY Or Star(StarNumber).SpeedX = 0 Or Star(StarNumber).SpeedY = 0)
  209.           Randomize
  210.           Star(StarNumber).SpeedX = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  211.           Star(StarNumber).SpeedY = Int(Rnd * WarpStarSpeed) - (WarpStarSpeed / 2)
  212.         Loop
  213.       End If
  214.       
  215.       Star(StarNumber).StarY = Star(StarNumber).StarY + (Star(StarNumber).SpeedY)
  216.       Star(StarNumber).StarX = Star(StarNumber).StarX + (Star(StarNumber).SpeedX)
  217.     End Select
  218.     
  219.     
  220. End Sub
  221.  
  222. Sub SendFile(file As String)
  223.  
  224. End Sub
  225.  
  226. Sub Play_Avi(VideoClipDir$) 'the VideoClipDir$ holds the VideoClips Dir data
  227. Dim lret
  228.  
  229.     lret = mciSendString("play VideoClipDir$", 0&, 0, 0) 'This plays the File
  230. End Sub
  231.  
  232. Sub PlayWav(Wav As String)
  233. Dim mc
  234.  
  235. mc = sndPlaySound(Wav, 1)
  236. End Sub
  237.