home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / tool / various / kalend / kalendar.bas next >
BASIC Source File  |  1995-02-27  |  4KB  |  115 lines
  1. Option Explicit
  2.  
  3. ' Drawing states for Kalendar_DrawDay
  4. Global Const KAL_STATE_NOT_SELECTED = 0         ' Day not selected
  5. Global Const KAL_STATE_SELECTED_WITH = 1        ' Day selected, Kalendar has focus
  6. Global Const KAL_STATE_SELECTED_WITHOUT = 2     ' Day selected, Kalendar does not have focus
  7. Global Const KAL_STATE_OTHERMONTH = 3           ' Day is not from this month.
  8.  
  9. Global Const KAL_PRINT_PORTRAIT = 1             ' Print Kalendar full page in portrait mode.
  10. Global Const KAL_PRINT_LANDSCAPE = 2            ' Print Kalendar landscape full page
  11. Global Const KAL_PRINT_USER = 3                 ' Print Kalendar as specified by user.
  12.  
  13. '--- For combo months.
  14. Dim updatingCombos As Integer
  15.  
  16. Sub KalDrawDay (Kal As Control, hdc As Integer, STATE As Integer, theDay As Long, dLeft As Single, dTop As Single, dRight As Single, dBottom As Single)
  17. Dim x As Integer
  18. Dim oldPen As Integer
  19. Dim txtDay As String
  20. Dim r As Rect
  21. Dim oldBrush
  22. Dim oldColor, oldTextColor
  23. Dim lx As Long
  24. Dim strTmp As String
  25.  
  26. Dim linePen As Integer
  27. Dim oldFont As Integer, theFont As Integer
  28.  
  29.     txtDay = Format(theDay, "d")
  30.  
  31.     KalWindowAPIRect dLeft, dTop, dRight, dBottom, r
  32.  
  33.     linePen = CreatePen(PS_SOLID, 1, Kal.LineColor)
  34.     theFont = KalMakeFont(hdc, Kal)
  35.  
  36.     oldPen = SelectObject(hdc, linePen)
  37.     oldFont = SelectObject(hdc, theFont)
  38.  
  39.     Select Case STATE
  40.     Case KAL_STATE_SELECTED_WITHOUT:
  41.         oldBrush = SelectObject(hdc, GetStockObject(LTGRAY_BRUSH))
  42.         oldColor = SetBkColor(hdc, RGB(192, 192, 192))
  43.         oldTextColor = SetTextColor(hdc, 0)
  44.     Case KAL_STATE_SELECTED_WITH:
  45.         oldBrush = SelectObject(hdc, GetStockObject(LTGRAY_BRUSH))
  46.         oldColor = SetBkColor(hdc, RGB(192, 192, 192))
  47.         oldTextColor = SetTextColor(hdc, RGB(255, 0, 0))
  48.     Case KAL_STATE_NOT_SELECTED:
  49.         oldBrush = SelectObject(hdc, GetStockObject(WHITE_BRUSH))
  50.         oldColor = SetBkColor(hdc, RGB(255, 255, 255))
  51.         oldTextColor = SetTextColor(hdc, 0)
  52.     End Select
  53.     
  54.     x = Rectangle(hdc, r.left, r.top, r.right, r.bottom)
  55.     
  56.     ' Draw the day number
  57.     InflateRect r, -1, -1
  58.     x = DrawText(hdc, txtDay, Len(txtDay), r, DT_LEFT Or DT_SINGLELINE)
  59.  
  60.     x = SelectObject(hdc, oldPen)
  61.     x = SelectObject(hdc, oldFont)
  62.     x = DeleteObject(linePen)
  63.     x = DeleteObject(theFont)
  64.  
  65.     x = SelectObject(hdc, oldBrush)
  66.     lx = SetBkColor(hdc, oldColor)
  67.     lx = SetTextColor(hdc, oldTextColor)
  68. End Sub
  69.  
  70. ' This function creates a font that is described by the font properties for a calendar.
  71. ' (It would probably work for any control that has fonts)
  72. Function KalMakeFont (hdc As Integer, Kal As Control) As Integer
  73. Dim FWBold As Integer
  74.  
  75.     If Kal.FontBold Then
  76.     FWBold = FW_BOLD
  77.     Else
  78.     FWBold = FW_NORMAL
  79.     End If
  80.  
  81.     KalMakeFont = CreateFont(-(Kal.FontSize * GetDeviceCaps(hdc, LOGPIXELSY) / 72), 0, 0, 0, FWBold, Kal.FontItalic, Kal.FontUnderline, Kal.FontStrikethru, 0, 0, 0, 0, DEFAULT_PITCH Or FF_DONTCARE, Kal.FontName)
  82.  
  83. End Function
  84.  
  85. Sub KalSetMonth (Kal As Control, newMonth As Integer, newDay As Integer, newYear As Integer)
  86.     If Not updatingCombos Then
  87.     Kal.Text = newMonth & "/" & newDay & "/" & newYear
  88.     End If
  89. End Sub
  90.  
  91. ' Converts rectangular twip coordinates into a Windows API Rectangle Structure
  92. Sub KalWindowAPIRect (dLeft As Single, dTop As Single, dRight As Single, dBottom As Single, rct As Rect)
  93.     rct.left = dLeft / Screen.TwipsPerPixelX
  94.     rct.top = dTop / Screen.TwipsPerPixelY
  95.     rct.right = dRight / Screen.TwipsPerPixelX
  96.     rct.bottom = dBottom / Screen.TwipsPerPixelY
  97. End Sub
  98.  
  99. Sub UpdateCombos (Kal As Control, cmbMonth As Control, cmbYear As Control)
  100. Dim i As Integer
  101.     updatingCombos = True
  102.     cmbMonth.ListIndex = Val(Format(Kal.Text, "m")) - 1
  103.  
  104.     For i = 0 To cmbYear.ListCount - 1
  105.     If cmbYear.List(i) = Format(Kal.Text, "yyyy") Then
  106.         cmbYear.ListIndex = i
  107.         Exit For
  108.     End If
  109.     Next
  110.  
  111.     updatingCombos = False
  112.  
  113. End Sub
  114.  
  115.