home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Water_2D__2163099212009.psc / M1.bas < prev    next >
BASIC Source File  |  2009-09-22  |  3KB  |  117 lines
  1. Attribute VB_Name = "M1"
  2. Type tp
  3.     x As Single
  4.     y As Single
  5. End Type
  6.  
  7.  
  8. Type tL
  9.     P1 As Long
  10.     P2 As Long
  11. End Type
  12.  
  13. Private Type RECT2
  14.     X1 As Long
  15.     Y1 As Long
  16.     X2 As Long
  17.     Y2 As Long
  18. End Type
  19.  
  20. Private Type POINTAPI
  21.     x As Long
  22.     y As Long
  23. End Type
  24.  
  25. Public BRUSH() As Long
  26. Public Rect As RECT2
  27.  
  28. Public Const DIV = 4 'decrease this on fast computer
  29. Public Const maxWH = 127
  30. Public Const minWH = -127
  31.  
  32.  
  33. Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  34. Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  35. 'Public Declare Function SetPixelV Lib "gdi32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  36. 'Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  37.  
  38.  
  39. Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  40. Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal hStretchMode As Long) As Long
  41.  
  42. Public Const STRETCHMODE = vbPaletteModeNone 'You can find other modes in the "PaletteModeConstants" section of your Object Browser
  43.  
  44.  
  45. Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT2, ByVal hBrush As Long) As Long
  46. Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  47.  
  48.  
  49. Sub Long2RGB(RGBcol As Long, ByRef R As Byte, ByRef G As Byte, ByRef B As Byte)
  50. R = RGBcol And &HFF ' set red
  51. G = (RGBcol And &H100FF00) / &H100 ' set green
  52. B = (RGBcol And &HFF0000) / &H10000 ' set blue
  53.  
  54. End Sub
  55.  
  56.  
  57. Sub InitBrush(r0, g0, b0, r1, g1, b1, MinValue, MaxValue, Optional NN = 255)
  58. Dim I
  59. Dim R
  60. Dim G
  61. Dim B
  62. Dim i2
  63. 'ReDim BRUSH(NN)
  64.  
  65. 'Range = (MaxValue - MinValue)
  66. '
  67. 'For I = MinValue To MaxValue Step Range / NN
  68. '
  69. '    i2 = Round(((I - MinValue) / Range) * NN)
  70. '
  71. '    R = r0 + (I - MinValue) + (r1 - r0) * (I - MinValue) / Range
  72. '    G = g0 + (I - MinValue) + (g1 - g0) * (I - MinValue) / Range
  73. '    B = b0 + (I - MinValue) + (b1 - b0) * (I - MinValue) / Range
  74. '
  75. '    BRUSH(i2) = CreateSolidBrush(RGB(R, G, B))
  76. '
  77. 'Next
  78.  
  79. ReDim BRUSH(MinValue To MaxValue)
  80. For I = MinValue To MaxValue
  81.     
  82.     
  83.     'R = (I * 0.7 + 127)
  84.     'G = (I * 0.9 + 127)
  85.     'B = (I + 127)
  86.     R = r0 + (r1 - r0) * (I - MinValue + 1) / 255
  87.     G = g0 + (g1 - g0) * (I - MinValue + 1) / 255
  88.     B = b0 + (b1 - b0) * (I - MinValue + 1) / 255
  89.     
  90.     
  91.     BRUSH(I) = CreateSolidBrush(RGB(R, G, B))
  92. Next
  93.  
  94. End Sub
  95.  
  96.  
  97.  
  98.  
  99. Public Sub MySetPixel(hdc, ByVal x, ByVal y, VV)
  100.  
  101.  
  102. Rect.X1 = (x) * DIV
  103. Rect.Y1 = (y) * DIV
  104. Rect.X2 = Rect.X1 + DIV '- 1
  105. Rect.Y2 = Rect.Y1 + DIV '- 1
  106.  
  107. '''VV = Round((VV + 1) / 4 * 255)
  108. ''VV = Round((VV - minWH) / (maxWH - minWH) * 255)
  109. 'VV = Round((VV - minWH) * Krange)
  110.  
  111. FillRect hdc, Rect, BRUSH(VV)
  112.  
  113.  
  114. End Sub
  115.  
  116.  
  117.