6. Заполнение элементов ActiveX

Public Function Init_ListView(OBJ As Object, SQL_str As String, Optional coloring As Boolean = False, Optional zagl As Integer = 0) As Integer

Dim rs As Recordset

Dim db As Database

Dim lstItem As ListItem

Dim n%, R%, G%, B%

With OBJ

'Set ListView style

.View = lvwReport

'This is not supported by ListView 5

.Gridlines = True

.FullRowSelect = True

'Clear Header and ListItems

.ListItems.Clear

.ColumnHeaders.Clear

Set db = CurrentDb()

Set rs = db.OpenRecordset(SQL_str)

If rs.RecordCount = 0 Then Exit Function

For n = 1 To rs.Fields.Count - 1

.ColumnHeaders.Add , , rs(n).NAME, IIf(Len(rs(n).NAME) < Len(rs(n)), Len(rs(n)), Len(rs(n).NAME)) * 100 + 400, lvwColumnLeft

Next

End With

rs.MoveFirst

Do Until rs.EOF

Set lstItem = OBJ.ListItems.Add()

lstItem.Text = rs(1)

lstItem.key = "k" & rs(0)

If rs.AbsolutePosition = 0 And zagl = 1 Then

lstItem.Bold = True

End If

If rs.AbsolutePosition = rs.RecordCount - 1 And zagl = 2 Then

lstItem.Bold = True

End If

If coloring Then

colorlist R, G, B

lstItem.ForeColor = rgb(R, G, B)

End If

For n = 2 To rs.Fields.Count - 1

lstItem.SubItems(n - 1) = Nz(rs(n))

If rs.AbsolutePosition = 0 And zagl = 1 Then

lstItem.ListSubItems(n - 1).Bold = True

End If

If rs.AbsolutePosition = rs.RecordCount - 1 And zagl = 2 Then

lstItem.ListSubItems(n - 1).Bold = True

End If

If coloring Then

colorlist R, G, B

lstItem.ListSubItems(n - 1).ForeColor = rgb(R, G, B)

End If

Next

rs.MoveNext

Loop

Init_ListView = rs.RecordCount

rs.Close

End Function

7. Изменение размеров форм

Public Sub StdResize(frm As Object, pfrm As Form)

Dim HOLE As Integer

HOLE = 110

With frm

If pfrm.InsideHeight < .Top + HOLE Then pfrm.InsideHeight = .Top - HOLE

If pfrm.InsideHeight > .Top + pfrm.Section(acFooter).HEIGHT + pfrm.Section(acHeader).HEIGHT + HOLE Then .HEIGHT = pfrm.InsideHeight - .Top - pfrm.Section(acFooter).HEIGHT - pfrm.Section(acHeader).HEIGHT - HOLE

If pfrm.InsideWidth > .Left + HOLE Then .WIDTH = pfrm.InsideWidth - .Left - HOLE

End With

End Sub

8. Календарь

Option Compare Database

Option Explicit

Public Const SWP_NOZORDER = &H4

Public Type gRect

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Public Type Dimensions

Width As Long

HEIGHT As Long

End Type

Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Public Declare Function GetFocus Lib "user32" () As Long

Public Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As gRect) As Long

Public Function ControlRect(ctl As Control) As gRect

ctl.SetFocus

GetWindowRect GetFocus(), ControlRect

End Function

Public Function FormDimensions(frm As Form) As Dimensions

Dim frmRect As gRect

GetWindowRect frm.hwnd, frmRect

FormDimensions.Width = frmRect.Right - frmRect.Left

FormDimensions.HEIGHT = frmRect.Bottom - frmRect.Top

End Function

Public Sub OpenCalendar(frm As Object)

OpenForm "Календарь_F", , , , , acHidden

Forms("Календарь_F").LastDate = frm.ActiveControl

Forms("Календарь_F").VISIBLE = True

While IsLoaded("Календарь_F"): DoEvents: Wend

End Sub