5 pages! Oh boy, did I mess up.
'PLAYS
'=====
'=====
'Global declarations
Public ReadVsEdit As Integer
Public imgSize As Integer
' USER FORM AND COMMAND BUTTONS
' =============================
Private Sub UserForm_Initialize()
'User Form initialization sub
ComboBox1.AddItem "READ ONLY"
ComboBox1.AddItem "EDITABLE"
ComboBox1.BoundColumn = 0 'Additems are a list starting from 0
ComboBox1.ListIndex = 0 'Display "Read Only" initially - Item 0
ReadVsEdit = 1 'Default is Read-only
imgSize = 1 'Start with small images
FirstCmdBut_Click 'Form opens showing first row
Image1.Enabled = True 'Responds to clicks
Image1.Visible = True
Image1.AutoSize = False
Image1.PictureSizeMode = fmPictureSizeModeZoom
Image1.Height = 150
Image1.Width = 210
Image1.Left = 354
Image1.Top = 288
End Sub
Private Sub ComboBox1_Change()
'Control for Edit ComboBox
If ComboBox1.Text = "READ ONLY" Then
ReadVsEdit = 1
AddCmdBut.Enabled = False
End If
If ComboBox1.Text = "EDITABLE" Then
ReadVsEdit = 2
AddCmdBut.Enabled = True
MsgBox "Warning: Enabling editing could lead to data-base corruption"
End If
End Sub
Private Sub ScrollBar2_Change()
'Scrollbar control sub
Dim LastRow As Long
ScrollBar2.Min = 1 'Left end of scrollbar = 1
LastRow = FindLastRow - 1
ScrollBar2.Max = LastRow 'Right end = LastRow
RowTxt.Value = ScrollBar2.Value 'Set current value into row number control, which
'will trigger GetData
End Sub
Private Sub FirstCmdBut_Click()
'Control to go to first entry in catalogue (Row 2)
RowTxt.Text = "2"
End Sub
Private Sub PrevCmdBut_Click()
'Control to go to previous row (exit silently if none)
Dim R As Long
Dim LastRow As Long
LastRow = FindLastRow
'Check that the text in the row mnumber box is a legal number.
'If so, 'r' becomes the row number. Otherwise exit.
If IsNumeric(RowTxt.Text) Then
R = CLng(RowTxt.Text)
R = R - 1
If R > 1 And R <= LastRow Then
RowTxt = FormatNumber(R, 0) 'The change in RowTxt value will trigger GetData
End If
End If
End Sub
Private Sub RowTxt_Change()
'Control to go to line shown in RowTxt box
Dim R As Long
Dim LastRow As Long
LastRow = FindLastRow
If IsNumeric(RowTxt.Text) = False Then Exit Sub 'Ignore if not a number
R = CLng(RowTxt.Text) 'Convert text to number
If R < 1 Then RowTxt.Value = 1 'If Row number out of range, force it into range
If R > LastRow Then RowTxt.Value = LastRow - 1
ScrollBar2.Value = RowTxt.Value 'Scrollbar slider set to current row
GetData
End Sub
Private Sub NextCmdBut_Click()
'Control to go to next row, if legal (exit silently if none)
Dim R As Long
Dim LastRow As Long
LastRow = FindLastRow
'Check that the text in the row mnumber box is a legal number.
'If so, 'r' becomes the row number. Otherwise exit.
If IsNumeric(RowTxt.Text) Then
R = CLng(RowTxt.Text)
R = R + 1
If R > 1 And R <= (LastRow - 1) Then
RowTxt = FormatNumber(R, 0) 'The change in RowTxt value will trigger GetData
End If
End If
End Sub
Private Sub LastCmdBut_Click()
'Control for 'Last' command
LastRow = FindLastRow - 1
RowTxt.Text = FormatNumber(LastRow, 0) 'Set RowTxt to last row number
End Sub
Private Sub CancelCmdBut_Click()
'Control for Cancel command
GetData 'Existing data is copied back into panel windows
End Sub
Private Sub SaveCmdBut_Click()
'Control for Save command.
PutData 'User will already have entered new data, which is now copied to database
End Sub
Private Sub AddCmdBut_Click()
'Control for Add command
LastRow = FindLastRow 'NB that FindLastRow finds value of first blank row
RowTxt.Text = FormatNumber(LastRow, 0) 'In effect, this displays the first blank row
End Sub
Private Sub FindButton_Click()
'Control for Find - also uses textbox 'Hittext'
Dim R As Long
Dim Target As String
N = CLng(RowTxt.Text) 'Current row number as shown in the row box
Target = HitText.Text 'Holds target string
R = Cells.Find(Target, Cells(N + 1, 1)).Row 'R = row number of the first hit after Row N+1
RowTxt.Text = FormatNumber(R, 0) 'Set RowTxt to row number of hit
End Sub
Private Sub Image1_Click()
'Toggles between large and small image formats
If imgSize = 2 Then
imgSize = 1
GetData
Image1.Height = 150
Image1.Width = 210
Image1.Left = 354
Image1.Top = 288
Exit Sub
ElseIf imgSize = 1 Then
imgSize = 2
GetData
Image1.Height = 660
Image1.Width = 940
Image1.Left = 5
Image1.Top = 5
Exit Sub
Else
MsgBox "Aaarghhh!"
End If
End Sub
'VARIOUS PROCESSES
'=================
Private Sub GetData()
'Subroutine to copy text entries from the catalogue entry pointed to
'in the RowTxt box, to the display panel
Dim R As Long
Dim LastRow As Long
LastRow = FindLastRow
'Check that the text in the row number box is a legal number.
'If so, 'r' becomes the row number. Otherwise exit.
If IsNumeric(RowTxt.Text) Then
R = CLng(RowTxt.Text)
Else
ClearData
MsgBox "Illegal row number"
Exit Sub
End If
If R < 1 Or R > LastRow Then
MsgBox "Row number out of range so reset to 2"
R = 2 'Force R back to legal value
End If
'Ensure that the Thumbnail box label is NOT set to quasi-hyperlink
With Label12 'Make label look normal (hyperlink would be blue and underlined)
.Font.Underline = False
.ForeColor = RGB(0, 0, 0)
End With
'R is a legal row number, so copy contents of row R into the various text windows, etc.
'NB that doing this will also trigger related Change event for that text window
PlayName.Text = Cells(R, 1) 'NB that each row will also trigger related Change event
Author.Text = Cells(R, 2)
StartDate.Text = Cells(R, 3)
NoOfPerfs.Text = Cells(R, 4)
CircaDate.Text = Cells(R, 5)
StartTime.Text = Cells(R, 6)
TicketPrices.Text = Cells(R, 7)
Venue.Text = Cells(R, 8)
TheatreSocy.Text = Cells(R, 9)
PartOf.Text = Cells(R, 10)
Description.Text = Cells(R, 11)
CastCrew.Text = Cells(R, 12)
Notes.Text = Cells(R, 13)
References.Text = Cells(R, 14)
Files.Text = Cells(R, 15)
ThumbnailFile.Text = Cells(R, 16)
'Inserting image from column 16 ("P")
DisableSave 'Since this sub is read-only, Save/Cancel greyed out
Image1.Visible = True
'b) address of cell containing image address in "A1" format. Col Letter is "P" for this catalogue, but
'has other letters for the other two lists.
imgpath = "P" + RowTxt.Text
imgpath = Range(imgpath).Text
If imgpath = "" Then
GoTo image 'Empty image address, so Display nul image
End If
If Right(imgpath, 4) <> ".jpg" Then
imgpath = "##MultiPage.jpg" 'Not a 'jpg file - read via hyperlink
With Label12 'Make label look like a hyperlink
.Font.Underline = True
.ForeColor = RGB(0, 128, 255)
End With
End If
'c) create full image path
imgpath = ActiveWorkbook.Path + "/Filestore1840-1900/" + imgpath
'd) Inserts Picture
'On Error GoTo ImageError 'E.g. case where file doesn't exist
Image1.Visible = True
image: Image1.Picture = LoadPicture(imgpath) 'imgpath
Me.Repaint
Exit Sub
ImageError: MsgBox ("Image error")
End Sub
Private Sub PutData()
'Subroutine to copy text entries from the display panel to the catalogue entry
'pointed to in the RowTxt box
Dim R As Long
Dim LastRow As Long
LastRow = FindLastRow
'Check that the text in the row number box is a legal number.
'If so, 'r' becomes the row number. Otherwise exit.
If IsNumeric(RowTxt.Text) Then
R = CLng(RowTxt.Text)
Else
MsgBox "Illegal row number"
Exit Sub
End If
'if r >1 but <= Last Row, copy the relevant display areas into their cell texts
'if r > Last Row, give fault message and exit.
If R > 1 And R <= LastRow Then
Cells(R, 1) = PlayName.Text
Cells(R, 2) = Author.Text
Cells(R, 3) = StartDate.Text
Cells(R, 4) = NoOfPerfs.Text
Cells(R, 5) = CircaDate.Text
Cells(R, 6) = StartTime.Text
Cells(R, 7) = TicketPrices.Text
Cells(R, 8) = Venue.Text
Cells(R, 9) = TheatreSocy.Text
Cells(R, 10) = PartOf.Text
Cells(R, 11) = Description.Text
Cells(R, 12) = CastCrew.Text
Cells(R, 13) = Notes.Text
Cells(R, 14) = References.Text
Cells(R, 15) = Files.Text
Cells(R, 16) = ThumbnailFile.Text
DisableSave 'Sub to disable Save and Cancel, since this sub is read only.
ElseIf R = 1 Then
ClearData 'Sub to clear display and exit, since you are looking at the caption row
Else 'r exceeds number of entries in catalogue, so fault exit
ClearData
MsgBox "Row number > number of entries"
End If
End Sub
Private Function FindLastRow()
' Finds last row - i.e. first row with first cell empty
Dim R As Long
Dim c As Integer
R = 2
c = 1
Do While R < 65536 And Len(Cells(R, 1).Text) > 0 'Loop down to first empty Col.1 cell
R = R + 1
Loop
TryNext: For c = 1 To 20 'Check that first 20 cells of line empty
If Len(Cells(R, c).Text) > 0 Then
R = R + 1
GoTo TryNext
End If
Next
FindLastRow = R
End Function
Private Sub ClearData()
' Subroutine to clear all cells in the display panel
PlayName.Text = ""
Author.Text = ""
StartDate.Text = ""
NoOfPerfs.Text = ""
CircaDate.Text = ""
StartTime.Text = ""
TicketPrices.Text = ""
Venue.Text = ""
TheatreSocy.Text = ""
PartOf.Text = ""
Description.Text = ""
CastCrew.Text = ""
Notes.Text = ""
References.Text = ""
Files.Text = ""
ThumbnailFile.Text = ""
End Sub
Private Sub DisableSave()
' Subroutine to disable the Save and Cancel command buttons when in read-only mode
SaveCmdBut.Enabled = False
CancelCmdBut.Enabled = False
End Sub
Private Sub EnableSave()
' Subroutine to enable the Save and Cancel command buttons when in read-write mode
SaveCmdBut.Enabled = True
CancelCmdBut.Enabled = True
If ReadVsEdit = 1 Then DisableSave 'EnableSave denied if Edit Control Box 'Read Only'
End Sub
'THE TEXT BOXES
'==============
'The user can always key on new information into any of the text boxes, but while Cancel and
'Save are disabled, this can never be entereed. So in all cases, all that has to happen is
'for any entry into any text window to trigger its _Change event and enable Cancel and Save.
Private Sub PlayName_Change()
'Play name
EnableSave
End Sub
Private Sub Author_Change()
'Author
EnableSave
End Sub
Private Sub StartDate_Change()
'Start Date
EnableSave
End Sub
Private Sub NoOfPerfs_Change()
'Number of performaneas
EnableSave
End Sub
Private Sub CircaDate_Change()
'Circa date - in effect the year
EnableSave
End Sub
Private Sub StartTime_Change()
'Start times of the performances
EnableSave
End Sub
Private Sub TicketPrices_Change()
'Ticket priees
EnableSave
End Sub
Private Sub Venue_Change()
'Venue
EnableSave
End Sub
Private Sub TheatreSocy_Change()
'Theatre society - e.g. dramsoc, grads, etc
EnableSave
End Sub
Private Sub PartOf_Change()
'What is a particular play part of - e.g. festival, evening of one-acts, etc.
EnableSave
End Sub
Private Sub Description_Change()
'Description - factual info about the show
EnableSave
End Sub
Private Sub CastCrew_Change()
'LIst of cast and crew and their roles
EnableSave
End Sub
Private Sub Notes_Change()
'Notes - e.g. library-type info, possible errors, etc.
EnableSave
End Sub
Private Sub References_Change()
'References
EnableSave
End Sub
Private Sub Files_Change()
'List of filenames of any files relating to the play - text or image
EnableSave
End Sub
Private Sub ThumbnailFile_Change()
'The filename of the image file that can be viewed from the user-form
EnableSave
End Sub
Private Sub Label12_Click()
'Treat as hyperlink
Dim Link As String
Link = ThumbnailTxt.Text
If Right(Link, 4) = ".jpg" Then Exit Sub 'Ignore click if this is a .jpg
If Left(Link, 5) = "http:" Then GoTo Viewit 'alredy a complete Web link
Link = ActiveWorkbook.Path & "/Filestore1840-1900/" & Link 'Create full path
On Error GoTo NoCanDo
Viewit: ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
Exit Sub
NoCanDo: MsgBox "Cannot open " & Link
End Sub
Reply With Quote
Originally Posted by SamT
! 
