home *** CD-ROM | disk | FTP | other *** search
/ Apollo 18: The Moon Missions / 990125_1647.ISO / Landsite / FTEST.FRM < prev    next >
Text File  |  1996-09-27  |  10KB  |  280 lines

  1. VERSION 4.00
  2. Begin VB.Form Form1 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00C0C0C0&
  5.    Caption         =   "Form1"
  6.    ClientHeight    =   6030
  7.    ClientLeft      =   1170
  8.    ClientTop       =   1470
  9.    ClientWidth     =   6720
  10.    ClipControls    =   0   'False
  11.    DrawStyle       =   6  'Inside Solid
  12.    FillStyle       =   0  'Solid
  13.    ForeColor       =   &H0000FF00&
  14.    Height          =   6435
  15.    Left            =   1110
  16.    LinkTopic       =   "Form1"
  17.    ScaleHeight     =   402
  18.    ScaleMode       =   3  'Pixel
  19.    ScaleWidth      =   448
  20.    Top             =   1125
  21.    Width           =   6840
  22.    Begin VB.PictureBox Picture1 
  23.       AutoRedraw      =   -1  'True
  24.       AutoSize        =   -1  'True
  25.       BorderStyle     =   0  'None
  26.       Height          =   3105
  27.       Left            =   7095
  28.       Picture         =   "FTEST.frx":0000
  29.       ScaleHeight     =   155.25
  30.       ScaleMode       =   2  'Point
  31.       ScaleWidth      =   81
  32.       TabIndex        =   6
  33.       Top             =   900
  34.       Width           =   1620
  35.    End
  36.    Begin VB.PictureBox terrain 
  37.       Appearance      =   0  'Flat
  38.       AutoRedraw      =   -1  'True
  39.       AutoSize        =   -1  'True
  40.       BackColor       =   &H80000005&
  41.       ForeColor       =   &H80000008&
  42.       Height          =   6030
  43.       Left            =   9195
  44.       Picture         =   "FTEST.frx":5B98
  45.       ScaleHeight     =   400
  46.       ScaleMode       =   3  'Pixel
  47.       ScaleWidth      =   150
  48.       TabIndex        =   5
  49.       Top             =   720
  50.       Width           =   2280
  51.    End
  52.    Begin VB.PictureBox picWork 
  53.       AutoRedraw      =   -1  'True
  54.       AutoSize        =   -1  'True
  55.       BackColor       =   &H00008000&
  56.       ForeColor       =   &H00000000&
  57.       Height          =   3345
  58.       Left            =   270
  59.       ScaleHeight     =   221
  60.       ScaleMode       =   3  'Pixel
  61.       ScaleWidth      =   407
  62.       TabIndex        =   4
  63.       Top             =   315
  64.       Width           =   6135
  65.    End
  66.    Begin VB.PictureBox vscreen 
  67.       AutoRedraw      =   -1  'True
  68.       AutoSize        =   -1  'True
  69.       BackColor       =   &H00C0C0C0&
  70.       ClipControls    =   0   'False
  71.       FillColor       =   &H0000FF00&
  72.       ForeColor       =   &H0000C000&
  73.       Height          =   3345
  74.       Left            =   285
  75.       ScaleHeight     =   221
  76.       ScaleMode       =   3  'Pixel
  77.       ScaleWidth      =   407
  78.       TabIndex        =   3
  79.       Top             =   285
  80.       Width           =   6135
  81.    End
  82.    Begin VB.CommandButton Command3 
  83.       Caption         =   "&End"
  84.       Height          =   495
  85.       Left            =   4260
  86.       TabIndex        =   2
  87.       Top             =   4260
  88.       Width           =   1215
  89.    End
  90.    Begin VB.CommandButton Command2 
  91.       Caption         =   "&Read"
  92.       Height          =   495
  93.       Left            =   2700
  94.       TabIndex        =   1
  95.       Top             =   4245
  96.       Width           =   1215
  97.    End
  98.    Begin VB.CommandButton Command1 
  99.       Caption         =   "&Write"
  100.       Height          =   495
  101.       Left            =   1080
  102.       TabIndex        =   0
  103.       Top             =   4230
  104.       Width           =   1215
  105.    End
  106. End
  107. Attribute VB_Name = "Form1"
  108. Attribute VB_Creatable = False
  109. Attribute VB_Exposed = False
  110. ' Windows API calls
  111. Private Declare Function GetPixel Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer) As Long
  112. Private Declare Function setpixel Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal crColor As Long) As Long
  113. Private Declare Function ellipse Lib "GDI" (ByVal hDC As Integer, ByVal nLeft As Integer, ByVal nTop As Integer, ByVal nRight As Integer, ByVal nBottom As Integer) As Long
  114. Private Declare Function LineTo Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer) As Integer
  115. Private Declare Function Polyline Lib "GDI" (ByVal hDC As Integer, lpPoints As POINTAPI, ByVal nCount As Integer) As Integer
  116. Private Declare Function MoveTo Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer) As Long
  117. '-----------------------------------------------------
  118. ' BITDEMO1.FRM
  119. ' This program demonstrates some of the methods used
  120. ' to display bitmaps and sprites.
  121. '-----------------------------------------------------
  122.  
  123. ' The number of pixels to offset the sprite
  124. ' each time it is moved.
  125. Const INCREMENT = 1
  126.  
  127. ' Constants for Raster Operations used by BitBlt function.
  128. Const SRCAND = &H8800C6      ' dest = source AND dest
  129. Const SRCCOPY = &HCC0020     ' dest = source
  130. Const SRCPAINT = &HEE0086    ' dest = source OR dest
  131.  
  132. ' The BitBlt Windows API call.
  133. Private Declare Function BitBlt Lib "GDI" (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
  134.  
  135. ' The width and height of the work area bitmap (picWork).
  136. Dim WorkWidth As Integer
  137. Dim WorkHeight As Integer
  138.  
  139. 'Scaling Constants
  140. Const XSCALE = 5
  141. Const YSCALE = 3
  142.  
  143. Private Sub Command1_Click()
  144.   Dim iOutNumber, linetok As Integer
  145.   Dim xpos, ypos(150) As Integer
  146.   Dim token(400) As String 'String to hold line
  147.   Dim color As Long
  148.   Static iRnd(2) As Integer, iCount As Integer
  149.   
  150.   'frmWrite.Show
  151.  ' Randomize
  152.   iOutNumber = FreeFile
  153.   
  154.   Open "c:\vb\test.dat" For Output As iOutNumber
  155.   For linetok = 1 To 400
  156.     For iCount = 1 To 150
  157.       xpos = (iCount)
  158.       ypos(iCount) = linetok
  159.     
  160.       color = GetPixel(terrain.hDC, xpos, ypos(iCount)) 'Mod 16
  161.       Select Case color
  162.         Case Is = 12320767
  163.           ypos(iCount) = 16
  164.         Case Is = 10222591
  165.           ypos(iCount) = 15
  166.         Case Is = 8125439
  167.           ypos(iCount) = 14
  168.         Case Is = 6028287
  169.           ypos(iCount) = 13
  170.         Case Is = 3930111
  171.           ypos(iCount) = 12
  172.         Case Is = 1832959
  173.           ypos(iCount) = 11
  174.         Case Is = 63487
  175.           ypos(iCount) = 10
  176.         Case Is = 57319
  177.           ypos(iCount) = 9
  178.         Case Is = 52175
  179.           ypos(iCount) = 8
  180.         Case Is = 46007
  181.           ypos(iCount) = 7
  182.         Case Is = 39839
  183.           ypos(iCount) = 6
  184.         Case Is = 34695
  185.           ypos(iCount) = 5
  186.         Case Is = 28527
  187.           ypos(iCount) = 4
  188.         Case Is = 23387
  189.           ypos(iCount) = 3
  190.         Case Is = 17219
  191.           ypos(iCount) = 2
  192.         Case Is = 16777215
  193.           ypos(iCount) = 1
  194.       End Select
  195.       'ypos = Int(color)
  196.       'Write #iOutNumber, xpos, ypos(iCount)
  197.       'iRnd(0) = Int(Rnd(1) * 100)
  198.       'iRnd(1) = Int(Rnd(1) * 100)
  199.       'Write #iOutNumber, iRnd(0), iRnd(1)
  200.       token(linetok) = token(linetok) + Str(ypos(iCount))
  201.       If iCount < 150 Then
  202.         token(linetok) = token(linetok) + ","
  203.       End If
  204.     Next
  205.     'Write #iOutNumber, ypos(1), ypos(2), ypos(3), ypos(4), ypos(5), ypos(6), ypos(7), ypos(8), ypos(9), ypos(10), ypos(11), ypos(12), ypos(13), ypos(14), ypos(15), ypos(16), ypos(17), ypos(18), ypos(19), ypos(20), ypos(21), ypos(22), ypos(23), ypos(24), ypos(25), ypos(26), ypos(27), ypos(28), ypos(29), ypos(30), ypos(31), ypos(32), ypos(33), ypos(34), ypos(35), ypos(36), ypos(37), ypos(38), ypos(39), ypos(40), ypos(41), ypos(42), ypos(43), ypos(44), ypos(45), ypos(46), ypos(47), ypos(48), ypos(49), ypos(50), ypos(51), ypos(52), ypos(53), ypos(54), ypos(55), ypos(56), ypos(57), ypos(58), ypos(59), ypos(60), ypos(5), ypos(6), ypos(7), ypos(8), ypos(9), ypos(10), ypos(11), ypos(12), ypos(13), ypos(14), ypos(15), ypos(2), ypos(3), ypos(4), ypos(5), ypos(6), ypos(7), ypos(8), ypos(9), ypos(10), ypos(11), ypos(12), ypos(13), ypos(14), ypos(15), ypos(2), ypos(3), ypos(4), ypos(5), ypos(6), ypos(7), ypos(8), ypos(9), ypos(10), ypos(11), ypos(12), ypos(13), ypos(14), ypos(15)
  206.     Write #iOutNumber, token(linetok)
  207.    Next
  208.   Close iOutNumber
  209.   
  210.   
  211. End Sub
  212.  
  213. Private Sub Command2_Click()
  214.   Dim iAutoNumber As Integer
  215.   Dim k, LSx, LSy, LSoffset, ykount, lineNum As Integer
  216.   Dim LSxPrime, LSyPrime, MyPos