View Full Version : ms progress bar 6.0
Hi,
i have tried looking at making a progress bar for my userform using labels and frames but could not work out how to do it. Now i have started looking into the standard ms progress bar thinking i could work out how to use that instead, but i cant. threads i have read up on have been no use to me as i couldnt understand what it was doing nor how to impliment it into my code.
my code (in userform1):
Private Sub ProgressBar1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
End Sub
Private Sub UserForm_activate()
'Open Userform on same screen as workbook and center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
'Unprotect Workbook
ThisWorkbook.Worksheets("Cover Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect Password:="password"
'PDF HYPERLINKING
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("U21:U2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02. PDFs\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".pdf"
shortname = ".pdf"
If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Next cll
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "-" to colour black
Dim cell As Range, iRange As Range
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".pdf" to underline
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
'Close USEHYPERLINKINGNOTEPDF
Unload UserForm1
'Protect Workbook
ThisWorkbook.Worksheets("Cover Page").protect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect Password:="password"
ThisWorkbook.Worksheets("L - Layout").protect Password:="password"
End Sub
What i am trying to do:
the run pdf hyperlinking routine is where i want the progress bar to look. that routine loops through about 2000 cells and i would like the progress bar to show me it's progress through that routine.
I have also posted this question here (http://www.mrexcel.com/forum/showthread.php?p=3100010#post3100010)
i am using excel 2007
i have been playing around with my code and have this atm
Private Sub UserForm_activate()
'Open Userform on same screen as workbook and
center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 *
Application.Width) - (0.5 * .Width)
.Top = Application.Top
+ (0.5 * Application.Height) - (0.5 * .Height)
End
With
'Text
Label2 = "Hyperlinking, please wait..."
'Button invisible
CommandButton2.Visible = False
'Unprotect Workbook
ThisWorkbook.Worksheets("Cover
Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect
Password:="password"
ThisWorkbook.Worksheets("E -
Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect
Password:="password"
ThisWorkbook.Worksheets("G - General
Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect
Password:="password"
'PDF HYPERLINKING
ProgressBar1.Min = 1
ProgressBar1.Max =
2018
For Count = 1 To 2018
ProgressBar1.Value =
Count
Me.Repaint
'select cells and clear values so removed PDFs become
unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
Set fs =
CreateObject("Scripting.FileSystemObject")
For Each cll In
Range("U21:U2039").Cells
fname =
"I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02.
PDFs\"
shortname =
""
For Each cel In Cells(cll.Row,
"H").Resize(,
5).Cells
fname = fname &
cel.Value
shortname = shortname &
cel.Value
Next
cel
fname = fname &
".pdf"
shortname =
".pdf"
If fs.FileExists(fname)
Then
cll.Parent.Hyperlinks.Add cll, fname, , ,
shortname
Else
cll.Value = "-"
End
If
Count = Count +
1
ProgressBar1.Value = Count
Next
cll
Next
'Select cells and make all text blue,
underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name =
"Calibri"
'Change text that contains "-" to colour black
Dim cell As
Range, iRange As Range
Set iRange =
Range("U21:U2039")
If iRange Is Nothing Then Exit
Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") >
0
.Font.ColorIndex = 0
End
Select
End With
Next
cell
Application.EnableEvents = True
'Change text that contains ".pdf" to
underline
Set iRange =
Range("U21:U2039")
If iRange Is Nothing Then Exit
Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") >
0
.Font.Underline =
xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become
unclickable
ActiveSheet.Range("U121:W121, U222:W222,
U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929,
U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535,
U1636:W1636, U1737:W1737, U1838:W1838,
U1939:W1939").Select
Selection.ClearContents
'Select
cells at top"
Cells(21,
1).Select
'Protect
Workbook
ThisWorkbook.Worksheets("Cover Page").protect
Password:="password"
ThisWorkbook.Worksheets("D -
Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect
Password:="password"
ThisWorkbook.Worksheets("F - Process
Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect
Password:="password"
ThisWorkbook.Worksheets("L -
Layout").protect Password:="password"
'Text
Label2 = "Hyperlinking
completed. Press 'OK' to continue."
'Button invisible
CommandButton2.Visible =
True
End Sub
Private Sub CommandButton2_Click()
'Close userform1
Unload
UserForm1
End Sub
the progress bar is working BUT i am coming up with and error once my loop has gone through. the error is happening at line
ProgressBar1.Value = Count
after the line
Count = Count + 1
i assume it is because the progress bar is finished and it doenst know what to do next?
i tried to use an if statement like
if count = 2018 then
move on to 'Select cells and make all text blue, underlined and "Calibri" text style etc
else
next
but then the routine says to me for without next.
ok, some progress
i now have 4 progress bars on the 1 userform
progressbarpdf
progressbardwg
progressbardir
progressbaroverall
the problems i am encountering are:
once a progress bar reaches it's max (ie: progressbarpdf) how do i get it to
1. stop trying to add 1 to the count and finish
2. keep the progress bar "full" while the routine now runs onto the next progress bar
and
my progressbaroverall isnt continuing from it's last count, it resets back to 1 everytime a new progress bar starts. i gather this is because i am using the word count for the individual progress bars as well as the overall one. is it possible to have multiple counts in the one routine without the program thinking they are the same thing?
here is my code thus far.
Private Sub UserForm_activate()
'Open Userform on same screen as workbook and center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
'Button invisible
CommandButton2.Visible = False
'Unprotect Workbook
ThisWorkbook.Worksheets("Cover Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect Password:="password"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6054
''ProgressBar1.Value = Count
'ProgressBarpdf
ProgressBarpdf.Min = 1
ProgressBarpdf.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'PDF HYPERLINKING
'Repaint Window
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("U21:U2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02. PDFs\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".pdf"
shortname = ".pdf"
If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Count = Count + 1
ProgressBarpdf.Value = Count
Count = Count + 1
ProgressBaroverall.Value = Count
Next cll
Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "-" to colour black
Dim cell As Range, iRange As Range
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".pdf" to underline
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBarpdf
ProgressBarpdf.Value = 2018
'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6054
ProgressBaroverall.Value = 2018
'ProgressBardwg
ProgressBardwg.Min = 1
ProgressBardwg.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'DWG HYPERLINKING
'Repaint Window
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("V21:V2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("V21:V2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".dwg"
shortname = ".dwg"
If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Count = Count + 1
ProgressBardwg.Value = Count
Count = Count + 1
ProgressBaroverall.Value = Count
Next cll
Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("V21:V2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "PDF Unavailable" to colour black
'Dim cell As Range, iRange As Range
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".dwg" to underline
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dwg") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBardwg
ProgressBardwg.Value = 2018
'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6054
ProgressBaroverall.Value = 4036
'ProgressBardir
ProgressBardir.Min = 1
ProgressBardir.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'DWG HYPERLINKING
'Repaint Window
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W21:W2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "U").Value = ".pdf", ".dir", "-")
If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Next cll
For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "V").Value = ".dwg", ".dir", "-")
If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Count = Count + 1
ProgressBardir.Value = Count
Count = Count + 1
ProgressBaroverall.Value = Count
Next cll
Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("W21:W2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "-" to colour black
''Dim cell As Range, iRange As Range
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".dir" to underline
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dir") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W121:W121, W222:W222, W323:W323, W424:W424, W525:W525, W626:W626, W727:W727, W828:W828, W929:W929, W1030:W1030, W1131:W1131, W1232:W1232, W1333:W1333, W1434:W1434, W1535:W1535, W1636:W1636, W1737:W1737, W1838:W1838, W1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
'Protect Workbook
ThisWorkbook.Worksheets("Cover Page").protect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect Password:="password"
ThisWorkbook.Worksheets("L - Layout").protect Password:="password"
'Text
Label2 = "Hyperlinking completed. Press 'OK' to continue."
'Button invisible
CommandButton2.Visible = True
End Sub
Private Sub CommandButton2_Click()
'Close userform1
Unload UserForm1
End Sub
alright, i have worked it out. i found the .width = complete command.
here is my code.
Private Sub UserForm_activate()
'Open Userform on same screen as workbook and center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
'Button invisible
CommandButton2.Visible = False
'Unprotect Workbook
ThisWorkbook.Worksheets("Cover Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect Password:="password"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6056
'ProgressBarpdf
ProgressBarpdf.Min = 1
ProgressBarpdf.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'PDF HYPERLINKING
'Repaint Window
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("U21:U2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02. PDFs\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".pdf"
shortname = ".pdf"
If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
If ProgressBarpdf.Value = 2018 Then
ProgressBarpdf.Width = Completed
Else
Count = Count + 1
ProgressBarpdf.Value = Count
End If
ProgressBaroverall.Value = Count
Next cll
Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "-" to colour black
Dim cell As Range, iRange As Range
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".pdf" to underline
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBardwg
ProgressBardwg.Min = 1
ProgressBardwg.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'DWG HYPERLINKING
'Repaint Window
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("V21:V2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("V21:V2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".dwg"
shortname = ".dwg"
If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
If ProgressBardwg.Value = 2018 Then
ProgressBardwg.Width = Completed
Else
Count = Count + 1
ProgressBardwg.Value = Count
End If
ProgressBaroverall.Value = Count + 2018
Next cll
Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("V21:V2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "PDF Unavailable" to colour black
'Dim cell As Range, iRange As Range
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".dwg" to underline
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dwg") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBardir
ProgressBardir.Min = 1
ProgressBardir.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'DWG HYPERLINKING
'Repaint Window
Me.Repaint
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W21:W2039").Select
Selection.ClearContents
'Run PDF Hyperlinking
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "U").Value = ".pdf", ".dir", "-")
If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Next cll
For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "V").Value = ".dwg", ".dir", "-")
If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
If ProgressBardir.Value = 2018 Then
ProgressBardir.Width = Completed
Else
Count = Count + 1
ProgressBardir.Value = Count
End If
ProgressBaroverall.Value = Count + 4036
Next cll
Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("W21:W2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"
'Change text that contains "-" to colour black
''Dim cell As Range, iRange As Range
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True
'Change text that contains ".dir" to underline
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dir") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True
'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W121:W121, W222:W222, W323:W323, W424:W424, W525:W525, W626:W626, W727:W727, W828:W828, W929:W929, W1030:W1030, W1131:W1131, W1232:W1232, W1333:W1333, W1434:W1434, W1535:W1535, W1636:W1636, W1737:W1737, W1838:W1838, W1939:W1939").Select
Selection.ClearContents
'Select cells at top"
Cells(21, 1).Select
'Protect Workbook
ThisWorkbook.Worksheets("Cover Page").protect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect Password:="password"
ThisWorkbook.Worksheets("L - Layout").protect Password:="password"
'Text
Label2 = "Hyperlinking completed. Press 'OK' to continue."
'Button invisible
CommandButton2.Visible = True
End Sub
Private Sub CommandButton2_Click()
'Close userform1
Unload UserForm1
End Sub
all i have to work out now is how to keep the .pdf bar full when it goes onto the .dwg bar instead of going blank.
Powered by vBulletin® Version 4.2.5 Copyright © 2025 vBulletin Solutions Inc. All rights reserved.