home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / tool / various / kalend / test.bas < prev    next >
BASIC Source File  |  1995-02-27  |  6KB  |  171 lines
  1. Option Explicit
  2. Type DateInfo
  3.     theDate As Long
  4.     theString As String
  5. End Type
  6.  
  7. Dim DateInfoList() As DateInfo
  8.  
  9. Type DateRange
  10.     StartDate As Long
  11.     EndDate As Long
  12.     Description As String
  13.     color As Long
  14. End Type
  15.  
  16. Dim DateRangeList() As DateRange
  17.  
  18. Global CR  As String
  19.  
  20. '==========
  21. ' Some Windows API Declarations
  22. Type RECT
  23.     left As Integer
  24.     top As Integer
  25.     right As Integer
  26.     bottom As Integer
  27. End Type
  28.  
  29. Type POINTAPI
  30.     X As Integer
  31.     Y As Integer
  32. End Type
  33.  
  34. Global Const PS_SOLID = 0
  35. Global Const DT_LEFT = &H0
  36. Global Const DT_SINGLELINE = &H20
  37. Global Const DT_VCENTER = &H4
  38. Global Const DT_CENTER = &H1
  39. Global Const LTGRAY_BRUSH = 1
  40. Global Const WHITE_BRUSH = 0
  41. Global Const FW_NORMAL = 400
  42. Global Const FW_BOLD = 700
  43. Global Const LOGPIXELSX = 88    '  Logical pixels/inch in X
  44. Global Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
  45. Global Const DEFAULT_PITCH = 0
  46. Global Const FF_DONTCARE = 0    '  Don't care or don't know.
  47. Global Const NULL_PEN = 8
  48. Global Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
  49. Global Const TRANSPARENT = 1
  50. Global Const DT_WORDBREAK = &H10
  51. Global Const BLACK_PEN = 7
  52.  
  53. Declare Function CreatePen Lib "GDI" (ByVal nPenStyle As Integer, ByVal nWidth As Integer, ByVal crColor As Long) As Integer
  54. Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
  55. Declare Function SetBkColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  56. Declare Function setBkMode Lib "GDI" (ByVal hDC As Integer, ByVal nBkMode As Integer) As Integer
  57. Declare Function SetTextColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  58. Declare Function Rectangle Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  59. Declare Function DrawText Lib "User" (ByVal hDC As Integer, ByVal lpStr As String, ByVal nCount As Integer, lpRect As RECT, ByVal wFormat As Integer) As Integer
  60. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  61. Declare Function GetStockObject Lib "GDI" (ByVal nIndex As Integer) As Integer
  62. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
  63. Declare Function CreateFont% Lib "GDI" (ByVal H%, ByVal W%, ByVal E%, ByVal O%, ByVal W%, ByVal I%, ByVal U%, ByVal S%, ByVal C%, ByVal OP%, ByVal CP%, ByVal Q%, ByVal PAF%, ByVal F$)
  64. Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
  65. 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
  66. Declare Function MoveTo Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
  67. Declare Function LineTo Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Integer
  68. Declare Function Ellipse Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  69. Declare Sub InflateRect Lib "User" (lpRect As RECT, ByVal X As Integer, ByVal Y As Integer)
  70.  
  71. Sub DateInfoAdd (aDate As Long, aString As String)
  72. Dim num As Integer
  73. Dim I As Integer
  74. Dim found As Integer
  75.  
  76.     found = False
  77.     On Error Resume Next
  78.     num = UBound(DateInfoList)
  79.     If Err <> 0 Then
  80.     num = 0
  81.     End If
  82.  
  83.     For I = 0 To num - 1
  84.     If DateInfoList(I).theDate = aDate Then
  85.         found = True
  86.         Exit For
  87.     End If
  88.     Next
  89.     
  90.     If Not found Then
  91.     On Error Resume Next
  92.     num = num + 1
  93.     
  94.     ReDim Preserve DateInfoList(num) As DateInfo
  95.     
  96.     DateInfoList(num - 1).theDate = aDate
  97.     DateInfoList(num - 1).theString = aString
  98.     Else
  99.     DateInfoList(I).theString = DateInfoList(I).theString + CR + aString
  100.     End If
  101. End Sub
  102.  
  103. Sub DateInfoMove (oldDate As Long, newDate As Long)
  104. Dim I As Integer
  105.     For I = 0 To UBound(DateInfoList) - 1
  106.     If DateInfoList(I).theDate = oldDate Then
  107.         DateInfoList(I).theDate = newDate
  108.         Exit Sub
  109.     End If
  110.     Next
  111. End Sub
  112.  
  113. Sub DateRangeAdd (FromDate As Long, ToDate As Long, Desc As String, color As Long)
  114. Dim num As Integer
  115. Dim I As Integer
  116. Dim found As Integer
  117.  
  118.     found = False
  119.     On Error Resume Next
  120.     num = UBound(DateRangeList)
  121.     If Err <> 0 Then
  122.     num = 0
  123.     End If
  124.  
  125.     On Error Resume Next
  126.     num = num + 1
  127.     
  128.     ReDim Preserve DateRangeList(num) As DateRange
  129.     
  130.     DateRangeList(num - 1).StartDate = FromDate
  131.     DateRangeList(num - 1).EndDate = ToDate
  132.     DateRangeList(num - 1).Description = Desc
  133.     DateRangeList(num - 1).color = color
  134.  
  135.  
  136. End Sub
  137.  
  138. Function GetDateInfo (aDate As Long) As String
  139. Dim I As Integer
  140.  
  141.     For I = 0 To UBound(DateInfoList) - 1
  142.     If DateInfoList(I).theDate = aDate Then
  143.         GetDateInfo = DateInfoList(I).theString
  144.         Exit Function
  145.     End If
  146.     Next
  147.  
  148.     GetDateInfo = ""
  149. End Function
  150.  
  151. Function GetDateRangeInfo (aDate As Long, Info As DateRange)
  152. Dim I As Integer
  153.  
  154.     On Error Resume Next
  155.     For I = 0 To UBound(DateRangeList) - 1
  156.     If DateRangeList(I).StartDate <= aDate And DateRangeList(I).EndDate >= aDate Then
  157.         Info = DateRangeList(I)
  158.         GetDateRangeInfo = True
  159.         Exit Function
  160.     End If
  161.     Next
  162.  
  163.     GetDateRangeInfo = False
  164.  
  165. End Function
  166.  
  167. Sub SetDescription (S As String)
  168.     Form6.txtSampleDescription.Text = S
  169. End Sub
  170.  
  171.