Реферат: Контроллер связываемых объектов

 ImageText As String

 X As Integer

 Y As Integer

 OutputFunPoints() As Integer

 OutputFunPointCo As Integer

 OutputDocPoints() As Integer

 OutputDocPointCo As Integer

End Type

Public Documents() As DocumentType

Public DocumentCo As Integer

Public Type FunctionType

 TotalNumber As Long

 FileName As String

 CreateDateTime As String

 Path As String

 UsedProgramm As String

 AutomatFunction As String

 AutoExeFlag As Boolean

 AskBeforeExe As Boolean

 Discription As String

 ImageIcon As String

 ImageText As String

 X As Integer

 Y As Integer

 DocumentsAndFunctionsLink As String

 InputDocPoints() As Integer

 InputDocPointCo As Integer

 OutputDocPoints() As Integer

 OutputDocPointCo As Integer

 InputFunPoints() As Integer

 InputFunPointCo As Integer

 OutputFunPoints() As Integer

 OutputFunPointCo As Integer

End Type

Public Functions() As FunctionType

Public FunctionCo As Integer

Public Sub ShowDocumentProperty(DocNumber As Integer)

On Error GoTo Err1

 MakeDocForm.Label4(0).Caption = FileLen(Documents(DocNumber).FileName)

 MakeDocForm.Label4(1).Caption = FileDateTime(Documents(DocNumber).FileName)

 MakeDocForm.Label4(2).Caption = Documents(DocNumber).CreateDateTime

 MakeDocForm.IconText.Text = Documents(DocNumber).ImageText

 MakeDocForm.IconImage.Picture = LoadPicture(Documents(DocNumber).ImageIcon)

 MakeDocForm.ImageIconText.Caption = Documents(DocNumber).ImageIcon

 MakeDocForm.Discrip.Text = Documents(DocNumber).Discription

 MakeDocForm.DocumentName = Documents(DocNumber).FileName

 If Documents(DocNumber).UsedProgramm = -1 Then

 MakeDocForm.Combo1.ListIndex = RegistrationCo + 1

 Else

 MakeDocForm.Combo1.ListIndex = GetREGIndex(Documents(DocNumber).UsedProgramm)

 End If

Exit Sub

Err1:

 Select Case MsgBox("Ïðîèçîøëà îøèáêà ïðè ïîïûòêå ñ÷èòàòü ôàéë.", vbAbortRetryIgnore + vbCritical)

 Case vbAbort

 End

 Case vbRetry

 Resume 0

 Case vbIgnore

 End Select

End Sub

Public Sub SaveRegCards()

 Dim FileNumber As Integer

 Dim a As Integer

On Error GoTo Err1

 FileNumber = FreeFile

 Open App.Path & "\RegisterCards" For Output As FileNumber

 Write #FileNumber, TotalRegCo, RegistrationCo

 For a = 0 To RegistrationCo

 With Registrations(a)

 Write #FileNumber, .TotalNumber, .Discription, .FileName, .NameApp, .FileMask

 End With

 Next a

 Close FileNumber

 Exit Sub

Err1:

 Select Case MsgBox("Ïðîèçîøëà îøèáêà ïðè ïîïûòêå çàïèñàòü ôàéë ðåãèñòðàöèè." _

 & Chr(13) & Chr(10) & Err.Number & Chr(13) & Chr(10) & _

 Err.Description, vbAbortRetryIgnore + vbCritical)

 Case vbAbort

 End

 Case vbRetry

 Resume 0

 End Select

End Sub

Public Sub MemberDocumentProperty(DocNumber As Integer)

 Documents(DocNumber).ImageText = MakeDocForm.IconText.Text

 Documents(DocNumber).ImageIcon = MakeDocForm.ImageIconText.Caption

 Documents(DocNumber).Discription = MakeDocForm.Discrip.Text

 Documents(DocNumber).FileName = MakeDocForm.DocumentName.Text

 Documents(DocNumber).CreateDateTime = MakeDocForm.Label4(0).Caption

 If MakeDocForm.Combo1.ListIndex = RegistrationCo + 1 Then

 Documents(DocNumber).UsedProgramm = -1

 Else

 Documents(DocNumber).UsedProgramm = Registrations(MakeDocForm.Combo1.ListIndex).TotalNumber

 End If

End Sub

Public Sub SaveProject(ProjectName As String)

 Dim FileNumber As Integer

 Dim a As Integer

 Dim b As Integer

 On Error GoTo Err1

 FileNumber = FreeFile

 Open ProjectName For Output As FileNumber

 Write #FileNumber, TotalDocCo, TotalFunCo, DocumentCo, FunctionCo

 For a = 0 To DocumentCo

 With Documents(a)

 Write #FileNumber, .TotalNumber, .FileName, .CreateDateTime, .UsedProgramm, _

 .Discription, .ImageIcon, .ImageText, .X, .Y, .OutputFunPointCo, _

 .OutputDocPointCo

 For b = 0 To .OutputFunPointCo

 Write #FileNumber, .OutputFunPoints(b)

 Next b

 For b = 0 To .OutputDocPointCo

 Write #FileNumber, .OutputDocPoints(b)

 Next b

 End With

 Next a

 For a = 0 To FunctionCo

 With Functions(a)

 Write #FileNumber, .TotalNumber, .FileName, .CreateDateTime, .UsedProgramm, _

 .AutomatFunction, .AutoExeFlag, .AskBeforeExe, .Discription, _

 .ImageIcon, .ImageText, .X, .Y, .DocumentsAndFunctionsLink, _

 .OutputFunPointCo, .OutputDocPointCo, .InputFunPointCo, _

 .InputDocPointCo

 For b = 0 To .OutputFunPointCo

 Write #FileNumber, .OutputFunPoints(b)

 Next b

 For b = 0 To .OutputDocPointCo

 Write #FileNumber, .OutputDocPoints(b)

 Next b

 For b = 0 To .InputFunPointCo

 Write #FileNumber, .InputFunPoints(b)

 Next b

 For b = 0 To .InputDocPointCo

 Write #FileNumber, .InputDocPoints(b)

 Next b

 End With

 Next a

 Close FileNumber

 Exit Sub

Err1:

 Select Case MsgBox("Ïðîèçîøëà îøèáêà ïðè ïîïûòêå çàïèñàòü ôàéë ïðîåêòà." _

 & Chr(13) & Chr(10) & Err.Number & Chr(13) & Chr(10) & _

 Err.Description, vbAbortRetryIgnore + vbCritical)

 Case vbAbort

 End

 Case vbRetry

 Resume 0

 End Select

End Sub

Public Sub LoadRegCards()

On Error GoTo Err1

 Dim FileNumber As Integer

 Dim a As Integer

 FileNumber = FreeFile

 Open App.Path & "\RegisterCards" For Input As FileNumber

 Input #FileNumber, TotalRegCo, RegistrationCo

 If RegistrationCo = -1 Then

 Close FileNumber

 Exit Sub

 End If

 ReDim Registrations(RegistrationCo)

 For a = 0 To RegistrationCo

 With Registrations(a)

 Input #FileNumber, .TotalNumber, .Discription, .FileName, .NameApp, .FileMask

 End With

 Next a

 Close FileNumber

 Exit Sub

Err1:

 Select Case MsgBox("Ïðîèçîøëà îøèáêà ïðè ïîïûòêå ñ÷èòàòü ôàéë ðåãèñòðàöèè." _

 & Chr(13) & Chr(10) & Err.Number & Chr(13) & Chr(10) & _

 Err.Description, vbAbortRetryIgnore + vbCritical)

 Case vbAbort

 End

 Case vbRetry

 Resume 0

 Case vbIgnore

 RegistrationCo = -1

 End Select

End Sub

Public Sub LoadProject(ProjectName As String)

 On Error GoTo Err1

 Dim FileNumber As Integer

 Dim a As Integer

 Dim b As Integer

 FileNumber = FreeFile

 Open ProjectName For Input As FileNumber

 Input #FileNumber, TotalDocCo, TotalFunCo, DocumentCo, FunctionCo

 If DocumentCo <> -1 Then

 ReDim Documents(DocumentCo)

 For a = 0 To DocumentCo

 With Documents(a)

 Input #FileNumber, .TotalNumber, .FileName, .CreateDateTime, .UsedProgramm, _

 .Discription, .ImageIcon, .ImageText, .X, .Y, .OutputFunPointCo, _

 .OutputDocPointCo

 If .OutputFunPointCo <> -1 Then

 ReDim .OutputFunPoints(.OutputFunPointCo)

 For b = 0 To .OutputFunPointCo

 Input #FileNumber, .OutputFunPoints(b)

 Next b

 End If

 If .OutputFunPointCo <> -1 Then

 ReDim .OutputDocPoints(.OutputDocPointCo)

 For b = 0 To .OutputDocPointCo

 Input #FileNumber, .OutputDocPoints(b)

 Next b

 End If

 End With

 Next a

 End If

 If FunctionCo <> -1 Then

 ReDim Functions(FunctionCo)

 For a = 0 To FunctionCo

 With Functions(a)

 Input #FileNumber, .TotalNumber, .FileName, .CreateDateTime, .UsedProgramm, _

 .AutomatFunction, .AutoExeFlag, .AskBeforeExe, .Discription, _

 .ImageIcon, .ImageText, .X, .Y, .DocumentsAndFunctionsLink, _

 .OutputFunPointCo, .OutputDocPointCo, .InputFunPointCo, _

 .InputDocPointCo

 If .OutputFunPointCo <> -1 Then

 ReDim .OutputFunPoints(.OutputFunPointCo)

 For b = 0 To .OutputFunPointCo

 Input #FileNumber, .OutputFunPoints(b)

 Next b

 End If

 If .OutputDocPointCo <> -1 Then

 ReDim .OutputDocPoints(.OutputDocPointCo)

 For b = 0 To .OutputDocPointCo

 Input #FileNumber, .OutputDocPoints(b)

 Next b

 End If

 If .InputFunPointCo <> -1 Then

 ReDim .InputFunPoints(.InputFunPointCo)

 For b = 0 To .InputFunPointCo

 Input #FileNumber, .InputFunPoints(b)

 Next b

 End If

 If .InputDocPointCo <> -1 Then

 ReDim .InputDocPoints(.InputDocPointCo)

 For b = 0 To .InputDocPointCo

 Input #FileNumber, .InputDocPoints(b)

 Next b

 End If

 End With

 Next a

 End If

 Close FileNumber

Exit Sub

Err1:

 Select Case MsgBox("Ïðîèçîøëà îøèáêà ïðè ïîïûòêå ñ÷èòàòü ôàéë ïðîåêòà." _

 & Chr(13) & Chr(10) & Err.Number & Chr(13) & Chr(10) _

 & Err.Description, vbAbortRetryIgnore + vbCritical)

 Case vbAbort

 End

 Case vbRetry

 Resume 0

 Case vbIgnore

 FunctionCo = -1

 DocumentCo = -1

 End Select

End Sub

Public Function GetREGIndex(TotalNumber As Long) As Integer

 Dim a As Integer

 For a = 0 To RegistrationCo

 If Registrations(a).TotalNumber = TotalNumber Then

 GetREGIndex = a

 Exit For

 End If

 Next a

End Function

Public Function GetDOCIndex(TotalNumber As Long) As Integer

 Dim a As Integer

 For a = 0 To DocumentCo

 If Documents(a).TotalNumber = TotalNumber Then

 GetDOCIndex = a

 Exit For

 End If

 Next a

End Function

Public Function GetFUNIndex(TotalNumber As Long) As Integer

 Dim a As Integer

 For a = 0 To FunctionCo

 If Functions(a).TotalNumber = TotalNumber Then

 GetFUNIndex = a

 Exit For

 End If

 Next a

End Function

Public Sub ShowProject()

 Dim a As Integer

 With MainForm

 For a = 0 To DocumentCo

 ImageCo = ImageCo + 1

 Load .ImageIcon(ImageCo)

 .ImageIcon(ImageCo).Top = Documents(a).Y

 .ImageIcon(ImageCo).Left = Documents(a).X

 .ImageIcon(ImageCo).Visible = True

 .ImageIcon(ImageCo).Enabled = True

 .ImageIcon(ImageCo).Picture = LoadPicture(Documents(a).ImageIcon)

 .ImageIcon(ImageCo).Tag = Documents(a).TotalNumber

 Load .ImageText(ImageCo)

 .ImageText(ImageCo).Top = Documents(a).Y + 500

 .ImageText(ImageCo).Left = Documents(a).X

 .ImageText(ImageCo).Visible = True

 .ImageText(ImageCo).Enabled = True

 .ImageText(ImageCo).Caption = Documents(a).ImageText

 .ImageText(ImageCo).Tag = 1

 Next a

End With

End Sub

‘******************************

‘Main Form Code

‘******************************

Option Explicit

Option Base 0

Private Sub Form_DragDrop(Source As Control, X As Single, Y As Single)

 Dim a As Integer

 Dim dX As Integer

 Dim dY As Integer

 If SelectIs = True Then

 dX = X - Source.Left

 dY = Y - Source.Top

 For a = 0 To ImageCo

 If ImageIcon(a).BorderStyle = 1 Then

 If ImageText(a).Tag = 1 Then

 Documents(GetDOCIndex(ImageIcon(a).Tag)).X = ImageIcon(a).Left + dX

 Documents(GetDOCIndex(ImageIcon(a).Tag)).Y = ImageIcon(a).Top + dY

 End If

 ImageIcon(a).Left = ImageIcon(a).Left + dX

 ImageIcon(a).Top = ImageIcon(a).Top + dY

 ImageText(a).Left = ImageIcon(a).Left

 ImageText(a).Top = ImageIcon(a).Top + 500

 End If

 Next a

 Else

 If ImageText(Source.Index).Tag = 1 Then

 Documents(GetDOCIndex(Source.Tag)).X = X

 Documents(GetDOCIndex(Source.Tag)).Y = Y

 End If

 Source.Left = X

 Source.Top = Y

 ImageText(Source.Index).Left = X

 ImageText(Source.Index).Top = Y + 500

 End If

End Sub

Private Sub Form_Load()

 Dim a As Integer

 LoadRegCards

 MakeDocForm.Combo1.Clear

 For a = 0 To RegistrationCo

 MakeDocForm.Combo1.AddItem Registrations(a).NameApp, a

 Next a

 MakeDocForm.Combo1.AddItem "Использовать стандартный обработчик", RegistrationCo + 1

 MakeDocForm.Combo1.ListIndex = RegistrationCo + 1

 LoadRegCards

 ImageCo = -1

 LoadProject App.Path & "\pro1.prj"

 ShowProject

 SaveProject App.Path & "\pro1.prj"

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

 If Button = 1 Then

 MouseX = X

 MouseY = Y

 SelectOn = True

 With selectrec

 .Visible = True

 .Height = 0

 .Width = 0

 .Left = X

 .Top = Y

 End With

 End If

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

 If SelectOn = True Then

 With selectrec

 If Y < MouseY Then

 .Top = Y

 .Height = MouseY - Y

 Else

 .Top = MouseY

 .Height = Y - MouseY

 End If

 If X < MouseX Then

 .Left = X

 .Width = MouseX - X

 Else

 .Left = MouseX

 .Width = X - MouseX

 End If

 End With

 End If

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

 Dim a As Integer

 If SelectOn = False Then

 MouseX = X

 MouseY = Y

 If Button = 2 Then

 MenuMake.Visible = True

 MenuRegistration.Visible = True

 MenuPropertyes.Visible = False

 MenuSeparator.Visible = False

 If SelectIs = True Then

 MenuDelete.Visible = True

 MenuCut.Visible = True

 MenuCopy.Visible = True

 Else

 MenuDelete.Visible = False

 MenuCut.Visible = False

 MenuCopy.Visible = False

 End If

' MenuPaste.Visible = False

 MenuFrom = -1

 MainForm.PopupMenu RightButtonMenuOnForm

 End If

 Else

 SelectOn = False

 selectrec.Visible = False

 SelectIs = False

 For a = 0 To ImageCo

 If (ImageIcon(a).Top > selectrec.Top) And _

 (ImageIcon(a).Left > selectrec.Left) And _

 (ImageIcon(a).Top < (selectrec.Top + selectrec.Height)) And _

 (ImageIcon(a).Left < (selectrec.Left + selectrec.Width)) Then

 SelectIs = True

 ImageIcon(a).BorderStyle = 1

 Else

 ImageIcon(a).BorderStyle = 0

 End If

 Next a

 End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

 SaveProject App.Path & "\pro1.prj"

 End

End Sub

Private Sub ImageIcon_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

 If Button = 1 Then

 ImageIcon(Index).Drag

 End If

End Sub

Private Sub ImageIcon_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

 If Button = 2 Then

 MenuMake.Visible = False

 MenuRegistration.Visible = False

 MenuPaste.Visible = False

 MenuPropertyes.Visible = True

 MenuSeparator.Visible = True

 MenuFrom = Index

 PopupMenu RightButtonMenuOnForm

 End If

End Sub

Private Sub Menu_Edit_Click()

 MainForm.PopupMenu RightButtonMenuOnForm

End Sub

Private Sub MenuDelete_Click()

Dim a As Integer

If SelectIs = True Then

 For a = 0 To ImageCo

 If ImageIcon(a).BorderStyle = 1 Then

 Delete a

 End If

 Next a

 SelectIs = False

Else

 Delete MenuFrom

End If

End Sub

Private Sub MenuMakeDocument_Click()

 DocumentCo = DocumentCo + 1

 TotalDocCo = TotalDocCo + 1

 ReDim Preserve Documents(DocumentCo)

 Documents(DocumentCo).X = MouseX

 Documents(DocumentCo).Y = MouseY

 CurDocument = DocumentCo

 DocumentIsChanged = True

 MakeDocForm.Label4(0).Caption = "0"

 MakeDocForm.Label4(1).Caption = str(Now)

 MakeDocForm.Label4(2).Caption = str(Now)

 MakeDocForm.IconText.Text = "Документ"

 MakeDocForm.IconImage.Picture = LoadPicture(App.Path & "\DefDoc.ico")

 MakeDocForm.ImageIconText = App.Path & "\DefDoc.ico"

 MakeDocForm.Discrip.Text = ""

 MakeDocForm.DocumentName = ""

 Canceled = False

 MakeDocForm.Show vbModal

 If Canceled = True Then

 DocumentCo = DocumentCo - 1

 TotalDocCo = TotalDocCo - 1

 ReDim Preserve Documents(DocumentCo)

 Exit Sub

 End If

 MemberDocumentProperty DocumentCo

 Documents(DocumentCo).TotalNumber = TotalDocCo

 Documents(DocumentCo).OutputFunPointCo = -1

 Documents(DocumentCo).OutputDocPointCo = -1

 ImageCo = ImageCo + 1

 Load ImageIcon(ImageCo)

 ImageIcon(ImageCo).Top = Documents(DocumentCo).Y

 ImageIcon(ImageCo).Left = Documents(DocumentCo).X

 ImageIcon(ImageCo).Visible = True

 ImageIcon(ImageCo).Enabled = True

 ImageIcon(ImageCo).Picture = LoadPicture(Documents(DocumentCo).ImageIcon)

 ImageIcon(ImageCo).Tag = Documents(DocumentCo).TotalNumber

 Load ImageText(ImageCo)

 ImageText(ImageCo).Top = Documents(DocumentCo).Y + 300

 ImageText(ImageCo).Left = Documents(DocumentCo).X

 ImageText(ImageCo).Visible = True

 ImageText(ImageCo).Enabled = True

 ImageText(ImageCo).Caption = Documents(DocumentCo).ImageText

 ImageText(ImageCo).Tag = 1 '**************** 1 = Это документ

End Sub

Private Sub MenuPropertyes_Click()

 Dim temp As Integer

 If MenuFrom >= 0 Then

 If ImageText(MenuFrom).Tag = 1 Then

 temp = GetDOCIndex(ImageIcon(MenuFrom).Tag)

 ShowDocumentProperty temp

 MakeDocForm.Show vbModal

 MemberDocumentProperty temp

 ImageText(MenuFrom).Caption = Documents(temp).ImageText

 ImageIcon(MenuFrom).Picture = LoadPicture(Documents(temp).ImageIcon)

 End If

 Else

 End If

End Sub

Private Sub MenuRegistration_Click()

 RegistrForm.Show vbModal

End Sub

Public Sub Delete(Index As Integer)

 Dim a As Integer

 Dim b As Integer

 If ImageText(Index).Tag = 1 Then

 b = GetDOCIndex(ImageIcon(Index).Tag)

 For a = b To DocumentCo - 1

 LSet Documents(a) = Documents(a + 1)

 Next a

 DocumentCo = DocumentCo - 1

 End If

 For a = 0 To ImageCo

 Unload ImageText(a)

 Unload ImageIcon(a)

 Next a

 ImageCo = -1

 SaveProject App.Path & "\temp~.prj"

 LoadProject App.Path & "\temp~.prj"

 ShowProject

End Sub

‘********************

‘Make doc form code

‘********************

Option Explicit

Private Sub Cancel_Click()

 Canceled = True

 Hide

End Sub

Private Sub Command1_Click()

On Error GoTo Err1

 RegDialog2.Flags = cdlOFNHideReadOnly

 If Combo1.ListIndex <> (RegistrationCo + 1) Then

 RegDialog2.Filter = "Âñå ôàéëû|*.*|" & _

 Registrations(Combo1.ListIndex).NameApp & "|" & _

 Registrations(Combo1.ListIndex).FileMask

 Else

 RegDialog2.Filter = "Âñå ôàéëû|*.*"

 End If

 RegDialog2.ShowOpen

 DocumentName.Text = RegDialog2.FileName

Err1:

End Sub

Private Sub Command2_Click()

On Error GoTo Err1

 RegDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly

 RegDialog.ShowOpen

 IconImage.Picture = LoadPicture(RegDialog.FileName)

 ImageIconText = RegDialog.FileName

Err1:

End Sub

Private Sub DocumentName_Change()

 DocumentIsChanged = True

End Sub

Private Sub Form_Activate()

 DocumentIsChanged = False

End Sub

Private Sub OkButton_Click()

 Dim ErrorFlag As Boolean

 Dim tmp As Integer

 Dim CurObject As Object

 Dim retShell As Long

 On Error GoTo Err1

 If DocumentName.Text = "" Then

 MsgBox ("Íåîáõîäèìî çàïîëíèòü ïîëå ""Äîêóìåíò :""")

 DocumentName.SetFocus

 Exit Sub

 End If

 If DocumentIsChanged Then

 ErrorFlag = False

 tmp = FileLen(DocumentName.Text)

 If ErrorFlag = True Then

 tmp = FreeFile

 Open DocumentName.Text For Output As tmp

 Close tmp

 End If

 End If

Hide

Exit Sub

Err1:

 If Err.Number = 53 Then

 ErrorFlag = True

 Else

 Select Case MsgBox("Ïðîèçîøëà îøèáêà íîìåð :" & Err.Number & _

 Chr(13) & Chr(10) _

 & Err.Description, vbAbortRetryIgnore + vbCritical)

 Case vbAbort

 End

 Case vbRetry

 Resume 0

 End Select

 End If

 Resume Next

End Sub

‘***********************

‘ registration form code

‘***********************

Option Explicit

Dim CurIndex As Integer

Private Sub Browser_Click()

 On Error GoTo Err1

 RegDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly

 RegDialog.ShowOpen

 Path = RegDialog.FileName

Err1:

End Sub

Private Sub Cancel_Click()

 LoadRegCards

 Hide

End Sub

Private Sub Combo1_Click()

 ShowRegCard Combo1.ListIndex

End Sub

Private Sub DestroyReg_Click()

Dim a As Integer

For a = CurIndex To RegistrationCo - 1

 LSet Registrations(a) = Registrations(a + 1)

Next a

RegistrationCo = RegistrationCo - 1

If RegistrationCo > -1 Then

 ReDim Preserve Registrations(RegistrationCo)

 If CurIndex > RegistrationCo Then CurIndex = CurIndex - 1

 ComboRemake

 CardShow CurIndex

 Combo1.ListIndex = CurIndex

 'ShowRegCard CurIndex

Else

 EnabledAll RegistrationCo

End If

EnabledAll RegistrationCo

End Sub

Private Sub Form_Activate()

 EnabledAll RegistrationCo

 If RegistrationCo = -1 Then Exit Sub

 ComboRemake

 CurIndex = 0

 CardShow CurIndex

 Combo1.ListIndex = CurIndex

End Sub

Private Sub NewReg_Click()

 TotalRegCo = TotalRegCo + 1

 RegistrationCo = RegistrationCo + 1

 ReDim Preserve Registrations(RegistrationCo)

 Registrations(RegistrationCo).NameApp = InputBox("Ââåäèòå èìÿ ïðèëîæåíèÿ", , "Ïðèëîæåíèå" + str(RegistrationCo + 1))

 If Registrations(RegistrationCo).NameApp = "" Then

 ReDim Preserve Registrations(RegistrationCo)

 TotalRegCo = TotalRegCo - 1

 RegistrationCo = RegistrationCo - 1

 Exit Sub

 End If

 Registrations(RegistrationCo).TotalNumber = TotalRegCo

 EnabledAll RegistrationCo

 ComboRemake

 Combo1.ListIndex = RegistrationCo

 'ShowRegCard RegistrationCo

 'Debug.Print

End Sub

Private Sub OkButton_Click()

 MemberCard

 SaveRegCards

 Hide

End Sub

Private Sub Rename_Click()

 Dim a As Integer

 Dim str As String

 a = Combo1.ListIndex

 str = InputBox("Ââåäèòå èìÿ ïðèëîæåíèÿ", , Registrations(a).NameApp)

 If str <> "" Then Registrations(a).NameApp = str

 ComboRemake

 Combo1.ListIndex = a

 'ShowRegCard a

End Sub

Private Sub ShowRegCard(NumRegCard As Integer)

 MemberCard

 CardShow NumRegCard

End Sub

Public Sub ComboRemake()

 Dim a As Integer

 Combo1.Clear

 For a = 0 To RegistrationCo

 Combo1.AddItem Registrations(a).NameApp, a

 Next a

End Sub

Public Sub EnabledAll(Yes As Integer)

 If Yes = -1 Then

 ComboRemake

 Browser.Enabled = False

 DestroyReg.Enabled = False

 Combo1.Enabled = False

 Rename.Enabled = False

 Path.Enabled = False

 Discrip.Enabled = False

 ListExt.Enabled = False

 Path.Text = ""

 Discrip.Text = ""

 ListExt.Text = ""

 Label1.Enabled = False

 Label2.Enabled = False

 Label3.Enabled = False

 Label4.Enabled = False

 Else

 DestroyReg.Enabled = True

 Combo1.Enabled = True

 Browser.Enabled = True

 Rename.Enabled = True

 Path.Enabled = True

 Discrip.Enabled = True

 ListExt.Enabled = True

 Label1.Enabled = True

 Label2.Enabled = True

 Label3.Enabled = True

 Label4.Enabled = True

 End If

End Sub

Public Sub CardShow(NumRegCard As Integer)

 Path.Text = Registrations(NumRegCard).FileName

 ListExt.Text = Registrations(NumRegCard).FileMask

 Discrip.Text = Registrations(NumRegCard).Discription

 CurIndex = NumRegCard

End Sub

Public Sub MemberCard()

 Registrations(CurIndex).FileName = Path.Text

 Registrations(CurIndex).FileMask = ListExt.Text

 Registrations(CurIndex).Discription = Discrip.Text

End Sub

Приложения

рис 1.1

Рис. 2.2

Рис. 3.1. Основное окно программы

Рис. 3.2. Меню "Правка"

Рис. 3.3. Окно свойств документа