Ðåôåðàò: Êîíòðîëëåð ñâÿçûâàåìûõ îáúåêòîâ
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. Îêíî ñâîéñòâ äîêóìåíòà
