home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / w3dvb5 / winprocs.bas < prev   
Encoding:
BASIC Source File  |  1997-12-22  |  4.6 KB  |  141 lines
  1. Attribute VB_Name = "WinProcs"
  2. ' Modulo contenente le API di Windows (a 32 bit) per
  3. ' l'emissione dei triangoli e lo shade colorato.
  4. ' Viene gestita una palette personalizzata.
  5.  
  6.  
  7. Type CornerRec
  8.   x As Long
  9.   Y As Long
  10. End Type
  11.  
  12.  
  13. Type PALETTEENTRY
  14.   peRed As Byte
  15.   peGreen As Byte
  16.   peBlue As Byte
  17.   peFlags As Byte
  18. End Type
  19.  
  20. Type LOGPALETTE
  21.   palVersion As Integer
  22.   palNumEntries As Integer
  23.   palPalEntry(16) As PALETTEENTRY
  24. End Type
  25.  
  26. Declare Function CreatePalette Lib "GDI32" (LogicalPalette As LOGPALETTE) As Long
  27. Declare Function CreatePen Lib "GDI32" (ByVal PenStyle As Long, ByVal Width As Long, ByVal Color As Long) As Long
  28. Declare Function CreatePolygonRgn Lib "GDI32" (lpPoints As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
  29. Declare Function CreateSolidBrush Lib "GDI32" (ByVal rgbColor As Long) As Long
  30. Declare Function DeleteObject Lib "GDI32" (ByVal hndobj As Long) As Long
  31. Declare Function FillRgn Lib "GDI32" (ByVal hDC As Long, ByVal hRegion As Long, ByVal hBrush As Long) As Long
  32. Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal Index As Long) As Long
  33. Declare Function GetSystemDirectory Lib "KERNEL32" Alias "GetSystemDirectoryA" (ByVal strBuffer As String, ByVal nBufLen As Long) As Long
  34. Declare Function GetWindowsDirectory Lib "KERNEL32" Alias "GetWindowsDirectoryA" (ByVal strBuffer As String, ByVal nBufLen As Long) As Long
  35. Declare Function LineTo Lib "GDI32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long) As Long
  36. Declare Function MoveToEx Lib "GDI32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, ByVal NullPtr As Long) As Long
  37. Declare Function PlaySound Lib "WINMM" (ByVal strName As String, ByVal hMod As Long, ByVal lFlags As Long) As Long
  38. Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
  39. Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal PaletteHandle As Long, ByVal Background As Long) As Long
  40. Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal ObjectHandle As Long) As Long
  41. Declare Function waveOutGetNumDevs Lib "WINMM" () As Long
  42.  
  43. Public Const PLANES = 14
  44. Public Const BITSPIXEL = 12
  45. Public Const PC_NOCOLLAPSE = 4
  46. Public Const COLORS = 24
  47. Public Const PS_SOLID = 0
  48.  
  49.  
  50. Public Const NumColors = 16
  51. Public Const TopColor = 12: ' all but last 3 colors are gray
  52.  
  53. Public OldPaletteHandle As Long
  54. Public RedGreenBlue(16) As Long
  55. Public Tilt As Double
  56. Public UsePalette As Boolean
  57. Public LogicalPalette As LOGPALETTE
  58. Public NumRealized As Long
  59. Sub SetColors(x As PictureBox)
  60.  
  61.   Dim ColorNum As Integer
  62.   Dim NumBits As Long
  63.   Dim NumColorsFree As Long
  64.   Dim Tint As Integer
  65.   
  66.   
  67.   OldPaletteHandle = 0
  68.   
  69.   NumColorsFree = 1
  70.   NumBits = GetDeviceCaps(x.hDC, PLANES) * GetDeviceCaps(x.hDC, BITSPIXEL)
  71.   If NumBits >= 31 Then
  72.     UsePalette = False
  73.   Else
  74.     Do While (NumBits > 0)
  75.       NumColorsFree = 2 * NumColorsFree
  76.       NumBits = NumBits - 1
  77.     Loop
  78.     NumColorsFree = NumColorsFree - GetDeviceCaps(x.hDC, COLORS)
  79.     If NumColorsFree < 16 Then
  80.       UsePalette = False
  81.     Else
  82.       UsePalette = True
  83.     End If
  84.   End If
  85.   LogicalPalette.palVersion = 3 * 256
  86.   LogicalPalette.palNumEntries = 16
  87.   For ColorNum = 0 To NumColors - 4
  88.     ' Ciclo per definire l'ombra del colore
  89.     Tint = (256 * ColorNum) \ (NumColors - 3)
  90.     LogicalPalette.palPalEntry(ColorNum).peRed = Tint
  91.     LogicalPalette.palPalEntry(ColorNum).peGreen = Tint
  92.     LogicalPalette.palPalEntry(ColorNum).peBlue = Tint
  93.     LogicalPalette.palPalEntry(ColorNum).peFlags = PC_NOCOLLAPSE
  94.     RedGreenBlue(ColorNum) = RGB(Tint, Tint, 0)
  95.   Next ColorNum
  96.   
  97.   If UsePalette Then
  98.     PaletteHandle = CreatePalette(LogicalPalette)
  99.     OldPaletteHandle = SelectPalette(x.hDC, PaletteHandle, 0)
  100.     NumRealized = RealizePalette(x.hDC)
  101.   End If
  102.  
  103. End Sub
  104.  
  105. Public Sub DrawTriangle(Pic As PictureBox, Box() As CornerRec, ColorNum As Integer)
  106.   
  107.   Dim Brush As Long
  108.   Dim rc As Long
  109.   Dim Region As Long
  110.   Dim BaseCol As Long
  111.   
  112.  UsePalette = False
  113.    
  114.   BaseCol = 16777216
  115.   
  116.   If UsePalette Then
  117.     Brush = CreateSolidBrush(BaseCol + ColorNum)
  118.     If Brush Then
  119.       Region = CreatePolygonRgn(Box(0), 3, 1)
  120.       If Region Then
  121.         rc = FillRgn(Pic.hDC, Region, Brush)
  122.         rc = DeleteObject(Region)
  123.       End If
  124.       rc = DeleteObject(Brush)
  125.     End If
  126.   Else
  127.     Brush = CreateSolidBrush(RedGreenBlue(ColorNum))
  128.     If Brush Then
  129.       Region = CreatePolygonRgn(Box(0), 3, 1)
  130.       If Region Then
  131.         rc = FillRgn(Pic.hDC, Region, Brush)
  132.         rc = DeleteObject(Region)
  133.       End If
  134.       rc = DeleteObject(Brush)
  135.     End If
  136.   End If
  137.  ' MsgBox "Ha disegnato un triangolo?"
  138. End Sub
  139.  
  140.  
  141.