Macro 1 First Third
********************
********************
Module 1:
Option Explicit
Option Private Module
Public dataWB As Workbook
Public weOpenedWB As Boolean
Public appWB As Workbook
Public appWS As Worksheet
Public wbWS As Worksheet
Public rngUpdateMessage As Range
Public rngUpdateMethod As Range
Public rngUpdateLabel As Range
Public rngUpdateTime As Range
Public rngTimerStatus As Range
Public rngHeader As Range
Public buttonStartTimer As MSForms.CommandButton
Public buttonStopTimer As MSForms.CommandButton
Public buttonCheckAll As MSForms.CommandButton
Public buttonPublishAll As MSForms.CommandButton
Public comboUpdateMethod As MSForms.ComboBox
Public buttonRefreshWB As MSForms.CommandButton
Public buttonCheckRow As MSForms.CommandButton
Public buttonPublishRow As MSForms.CommandButton
Public buttonClearRow As MSForms.CommandButton
Public buttonBrowse As MSForms.CommandButton
Public Const dataWBColName = "Workbook"
Public Const dataTypeColName = "Data Type"
Public Const dataWSColName = "Worksheet"
Public Const dataRangeColName = "Range"
Public Const dataChartColName = "Chart Name"
Public Const imageLocTypeColName = "Location Type"
Public Const imageftpSiteColName = "ftp Site Name"
Public Const imageFolderColName = "Folder"
Public Const imageUsernameColName = "Username"
Public Const imagePasswordColName = "Password"
Public Const imageTypeColName = "File Type"
Public Const imageSourceColName = "Source Type"
Public Const imageWSColName = " Worksheet "
Public Const imageRangeColName = " Range "
Public Const imageNameColName = "(without extension)"
Public Const messageColName = "Last Message"
Public Const dateColName = "Date"
Public Const timeColName = "Time"
Public dataWBCol, dataTypeCol, dataWSCol, dataRangeCol, dataChartCol As Long
Public imageLocTypeCol, imageftpSiteCol, imageFolderCol, imageUsernameCol,
imagePasswordCol As Long
Public imageTypeCol, imageSourceCol, imageWSCol, imageRangeCol, imageNameCol
As Long
Public dateCol, timeCol, messageCol As Long
Public timerAddInName As String
Public Const timerAddInMacro = "TimedPublish"
Public RunWhat As String
Public Const AppName = "Excel"
Public Const AppSection = "Data Publisher"
Public userChangedCombo As Boolean
Public oldRow As Long
Public Const buttonGreen = &H80FF80
Public Const buttonRed = &H8080FF
Public tempWeOpenedWB As Boolean
Sub Start()
Call SaveSetting(AppName, AppSection, "Workbook Name", ThisWorkbook.FullName)
timerAddInName = GetSetting(AppName, _
AppSection, _
"Add-In Name", _
"")
RunWhat = "'" & timerAddInName & "'!" & timerAddInMacro
Set appWB = ThisWorkbook
Set appWS = appWB.Worksheets(1)
Set wbWS = ThisWorkbook.Worksheets(2)
Set buttonStartTimer = ThisWorkbook.Worksheets(1).btnStartTimer
Set buttonStopTimer = ThisWorkbook.Worksheets(1).btnStopTimer
Set buttonCheckAll = ThisWorkbook.Worksheets(1).btnCheckAll
buttonCheckAll.BackColor = vbButtonFace
Set buttonPublishAll = ThisWorkbook.Worksheets(1).btnPublishAll
buttonPublishAll.BackColor = vbButtonFace
Set comboUpdateMethod = ThisWorkbook.Worksheets(1).cboUpdateMethod
If comboUpdateMethod.ListCount = 0 Then
comboUpdateMethod.AddItem ("Preset Time")
comboUpdateMethod.AddItem ("Interval")
End If
Set rngUpdateMessage = appWS.Range("_UpdateMessage")
Set rngUpdateMethod = appWS.Range("_UpdateMethod")
Set rngUpdateLabel = appWS.Range("_UpdateTimeLabel")
Set rngUpdateTime = appWS.Range("_UpdateTime")
Set rngTimerStatus = appWS.Range("_TimerStatus")
Set rngHeader = appWS.Range("_Header")
Set buttonRefreshWB = ThisWorkbook.Worksheets(1).btnRefreshWB
Set buttonCheckRow = ThisWorkbook.Worksheets(1).btnCheckRow
Set buttonPublishRow = ThisWorkbook.Worksheets(1).btnPublishRow
Set buttonClearRow = ThisWorkbook.Worksheets(1).btnClearRow
Set buttonBrowse = ThisWorkbook.Worksheets(1).btnBrowse
appWS.Activate
appWS.Cells(1, 1).Select
oldRow = 1
CheckColumns (True)
wbWS.UsedRange.ClearContents
StartWBList
weOpenedWB = False
appWS.Unprotect
If GetSetting(AppName, AppSection, "Next Alarm", "") <> "" Then 'Timer is
ON
userChangedCombo = False
comboUpdateMethod.Value = GetSetting(AppName, AppSection, "Update
Method", "Preset Time")
userChangedCombo = True
'Now force the combobox change event to update the format of Update
Time; _
we'll overwrite it with the value from the registry very soon
ChangeUpdateMethod
rngUpdateMethod.Value = comboUpdateMethod.Value
If comboUpdateMethod.Value = "Preset Time" Then
rngUpdateTime.Value = CDate(GetSetting(AppName, AppSection, "Update
Time", "12:00"))
Else
rngUpdateTime.Value = GetSetting(AppName, AppSection, "Update Time",
"60")
End If
ShowTimer ("ON")
Else 'Timer is OFF
'We need to set the value of the combobox to match Update Time, because
the combobox is _
blank when the program starts
userChangedCombo = False
If rngUpdateLabel = "Update Time:" Then
comboUpdateMethod.Value = "Preset Time"
Else
comboUpdateMethod.Value = "Interval"
End If
userChangedCombo = True
ShowTimer ("OFF")
End If
ProtectWS
End Sub
Function CheckColumns(Optional ByVal showErrors As Boolean = True) As String
CheckColumns = "" 'default
'Workbook column
If IsError(Application.Match(dataWBColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & dataWBColName & "' column" & vbCr & _
"from 'What to Publish'.")
GoTo CheckErrors
Else
dataWBCol = Application.Match(dataWBColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Data Type column
If IsError(Application.Match(dataTypeColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & dataTypeColName & "' column" & vbCr & _
"from 'What to Publish'.")
GoTo CheckErrors
Else
dataTypeCol = Application.Match(dataTypeColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'DATA Worksheet column
If IsError(Application.Match(dataWSColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & dataWSColName & "' column" & vbCr & _
"from 'What to Publish'.")
GoTo CheckErrors
Else
dataWSCol = Application.Match(dataWSColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'DATA Range column
If IsError(Application.Match(dataRangeColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & dataRangeColName & "' column" & vbCr & _
"from 'What to Publish'.")
GoTo CheckErrors
Else
dataRangeCol = Application.Match(dataRangeColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Chart column
If IsError(Application.Match(dataChartColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & dataChartColName & "' column" & vbCr & _
"from 'What to Publish'.")
GoTo CheckErrors
Else
dataChartCol = Application.Match(dataChartColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Location type column
If IsError(Application.Match(imageLocTypeColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & imageLocTypeColName & "' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageLocTypeCol = Application.Match(imageLocTypeColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'ftp Site column
If IsError(Application.Match(imageftpSiteColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & imageftpSiteColName & "' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageftpSiteCol = Application.Match(imageftpSiteColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Folder column
If IsError(Application.Match(imageFolderColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & imageFolderColName & "' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageFolderCol = Application.Match(imageFolderColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Username column
If IsError(Application.Match(imageUsernameColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & imageUsernameColName & "' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageUsernameCol = Application.Match(imageUsernameColName, rngHeader, 0)
+ rngHeader.Column - 1
End If
'Password column
If IsError(Application.Match(imagePasswordColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & imagePasswordColName & "' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imagePasswordCol = Application.Match(imagePasswordColName, rngHeader, 0)
+ rngHeader.Column - 1
End If
'File Type column
If IsError(Application.Match(imageTypeColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & imageTypeColName & "' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageTypeCol = Application.Match(imageTypeColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'File Name Source column
If IsError(Application.Match(imageSourceColName, rngHeader, 0)) Then
CheckColumns = ("Missing 'File Name " & imageSourceColName & "' column"
& vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageSourceCol = Application.Match(imageSourceColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'IMAGE Worksheet column
If IsError(Application.Match(imageWSColName, rngHeader, 0)) Then
CheckColumns = ("Missing 'File Name" & imageWSColName & "' column" &
vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageWSCol = Application.Match(imageWSColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'IMAGE Range column
If IsError(Application.Match(imageRangeColName, rngHeader, 0)) Then
CheckColumns = ("Missing 'File Name" & imageRangeColName & "' column" &
vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageRangeCol = Application.Match(imageRangeColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Image File Name (Manual) column
If IsError(Application.Match(imageNameColName, rngHeader, 0)) Then
CheckColumns = ("Missing 'Manual File Name' column" & vbCr & _
"from 'Where to Publish'.")
GoTo CheckErrors
Else
imageNameCol = Application.Match(imageNameColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Date column
If IsError(Application.Match(dateColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & dateColName & "' column" & vbCr & _
"from 'Last Operation'.")
GoTo CheckErrors
Else
dateCol = Application.Match(dateColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Time column
If IsError(Application.Match(timeColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & timeColName & "' column" & vbCr & _
"from 'Last Operation'.")
GoTo CheckErrors
Else
timeCol = Application.Match(timeColName, rngHeader, 0) +
rngHeader.Column - 1
End If
'Message column
If IsError(Application.Match(messageColName, rngHeader, 0)) Then
CheckColumns = ("Missing '" & messageColName & "' column" & vbCr & _
"from 'Last Operation'.")
GoTo CheckErrors
Else
messageCol = Application.Match(messageColName, rngHeader, 0) +
rngHeader.Column - 1
End If
Exit Function
CheckErrors:
If showErrors = True Then MsgBox (CheckColumns)
End Function
Sub ChangeUpdateMethod()
'Note: Protection needs to be handled by calling Sub
If comboUpdateMethod.Value = "Preset Time" Then
rngUpdateLabel.Value = "Update Time:"
rngUpdateTime.Value = ""
rngUpdateTime.NumberFormat = "HH:MM"
With rngUpdateTime.Validation
.Delete
rngUpdateTime.Select
.Add Type:=xlValidateTime, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="0", _
Formula2:="23:59"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = "Please enter a valid time in HH:MM format."
.ShowInput = True
.ShowError = True
End With
rngUpdateTime.Value = "12:00"
Else
rngUpdateLabel.Value = "Minutes between updates:"
rngUpdateTime.Value = ""
rngUpdateTime.NumberFormat = "General"
With rngUpdateTime.Validation
.Delete
rngUpdateTime.Select
.Add Type:=xlValidateDecimal, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=1/60", _
Formula2:="1440"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = "Please enter a number of minutes between" & vbCr & _
".016667 (1 second) and 1440 (24 hours)."
.ShowInput = True
.ShowError = True
End With
rngUpdateTime.Value = 60
End If
End Sub
Sub StartTimer(Optional ByVal showMessages As Boolean = True)
Dim timerAddIn As Workbook
Dim when As Double
Dim h, m, s As Integer
Dim runWhen As Double
'Verify timer add-in is loaded
Set timerAddIn = Nothing
On Error Resume Next
Set timerAddIn = Application.Workbooks(timerAddInName)
On Error GoTo 0
If timerAddIn Is Nothing Then
ShowError ("The Add-In '" & timerAddInName & "' must be loaded before" &
vbCr & _
"the timer can be started.")
Exit Sub
End If
'Start timer
Select Case comboUpdateMethod.Value
Case "Preset Time"
StopTimer (False)
runWhen = rngUpdateTime.Value
Case "Interval"
StopTimer (False)
when = rngUpdateTime.Value
h = Int(when / 60)
when = when - h * 60
m = Int(when)
when = when - m
s = Int(when * 60)
runWhen = Time + TimeSerial(h, m, s)
Case Else
If showMessages = True Then MsgBox ("Bad Update Method.")
Exit Sub
End Select
Call SaveSetting(AppName, AppSection, "Next Alarm", Format(runWhen,
"HH:MM:SS"))
runWhen = CDbl(CDate(Format(runWhen, "HH:MM:SS"))) 'recalculate based on
saved value to make sure _
that later reads of
value calculate exact _
same result
Application.OnTime EarliestTime:=runWhen, Procedure:=RunWhat, Schedule:=True
appWS.Unprotect
'Since we turned the timer ON, we need to save the settings so that if the
user doesn't _
save the workbook, then the next they open it, it will match the timer
Call SaveSetting(AppName, AppSection, "Update Method",
comboUpdateMethod.Value)
If comboUpdateMethod.Value = "Preset Time" Then
Call SaveSetting(AppName, AppSection, "Update Time",
Format(rngUpdateTime.Value, "HH:MM"))
Else
Call SaveSetting(AppName, AppSection, "Update Time", rngUpdateTime.Value)
End If
ShowTimer ("ON")
ProtectWS
If showMessages = True Then MsgBox ("Timer started.")
End Sub
Sub StopTimer(Optional ByVal showMessages As Boolean = True)
Dim when As String
Dim runWhen As Double
Dim timerStopped As Boolean
when = GetSetting(AppName, AppSection, "Next Alarm", "")
If when = "" Then
If showMessages = True Then ShowError ("The timer has not been started.")
Exit Sub
End If
runWhen = CDbl(CDate(when))
On Error GoTo StopTimerError
Application.OnTime EarliestTime:=runWhen, Procedure:=RunWhat, Schedule:=False
On Error GoTo 0
timerStopped = True
GoTo Continue
StopTimerError:
On Error GoTo 0
If showMessages = True Then ShowError ("The action to stop the Timer could
not verified," & vbCr & _
"but it is safe to continue. If you
wish to" & vbCr & _
"guarantee the Timer has stopped,
please close" & vbCr & _
"Excel when it is convenient to do
so.")
timerStopped = False
Continue:
Call SaveSetting(AppName, AppSection, "Next Alarm", "")
appWS.Unprotect
ShowTimer ("OFF")
ProtectWS
If showMessages = True And timerStopped = True Then MsgBox ("Timer stopped.")
End Sub
Sub TimerPublish()
PublishAll (False)
ThisWorkbook.Save
StartTimer (False)
End Sub
Function PublishRow(ByVal rowNumber As Long, _
ByVal closeIfOpened As Boolean, _
ByVal showMessages As Boolean) As Boolean
'Note:
' closeIfOpened denotes whether or not to close the data workbook if
we opened it _
(may want to leave it open if next row is from the same workbook)
' returns TRUE if no errors, FALSE otherwise
'****************************************
'Variable declarations
Dim dataType, dataWSName, dataRangeName, dataChartName As String
Dim imageLocType, imageftpSiteName, imageFolderName, imageUsername,
imagePassword As String
Dim imageType, imageSource, imageWSName, imageRangeName, imageFileName
Dim dataWS As Worksheet
Dim imageWS As Worksheet
Dim dataChart As ChartObject
Dim dName, iName As Name
Dim dRange, iRange As Range
Dim imageContainerWS As Worksheet
Dim imageContainer As ChartObject
Dim rangeWidth, rangeHeight As Long
Dim widthScale, heightScale As Single
Dim testName As Name
Dim testRange As Range
Dim testFile As String
Dim ImageFileFullName As String
Dim eMessage As String
Dim okMessage As String
Dim tempFolder As String
Dim ftpFileFullName As String
Dim instance As Excel.Application
'****************************************
okMessage = "Image updated"
eMessage = okMessage 'default (no errors)
tempFolder = Environ("temp")
'Data Workbook
'(File should already be opened from CheckRow)
'Data Type
dataType = UCase(appWS.Cells(rowNumber, dataTypeCol).Value)
'Data Worksheet
If dataType = "UNNAMED RANGE" Or dataType = "CHART OBJECT" Then
dataWSName = appWS.Cells(rowNumber, dataWSCol).Value
Set dataWS = dataWB.Worksheets(dataWSName)
End If
'Data Range
If dataType = "NAMED RANGE" Or dataType = "UNNAMED RANGE" Then
dataRangeName = appWS.Cells(rowNumber, dataRangeCol).Value
If dataType = "NAMED RANGE" Then
'Named Range
Set dName = dataWB.Names(dataRangeName)
Set dRange = dName.RefersToRange
Else
'Unnamed Range
Set dRange = dataWS.Range(dataRangeName)
End If
End If
'Chart Object
If dataType = "CHART OBJECT" Then
dataChartName = appWS.Cells(rowNumber, dataChartCol).Value
Set dataChart = dataWS.ChartObjects(dataChartName)
End If
'Image Location Type
imageLocType = UCase(appWS.Cells(rowNumber, imageLocTypeCol).Value)
'Image ftp Site Name
imageftpSiteName = appWS.Cells(rowNumber, imageftpSiteCol).Value
'Image Folder
imageFolderName = appWS.Cells(rowNumber, imageFolderCol).Value
If Right(imageFolderName, 1) = "\" Then imageFolderName =
Left(imageFolderName, Len(imageFolderName) - 1)
'Image Username
imageUsername = appWS.Cells(rowNumber, imageUsernameCol).Value
'Image Password
imagePassword = Decode(appWS.Cells(rowNumber, imagePasswordCol).Value)
'Image Type
imageType = appWS.Cells(rowNumber, imageTypeCol).Value
'Image Source
imageSource = UCase(appWS.Cells(rowNumber, imageSourceCol).Value)
'Image Worksheet
If imageSource = "UNNAMED RANGE" Then
imageWSName = appWS.Cells(rowNumber, imageWSCol).Value
Set imageWS = dataWB.Worksheets(imageWSName)
End If
'Image Range
If imageSource = "NAMED RANGE" Or imageSource = "UNNAMED RANGE" Then
imageRangeName = appWS.Cells(rowNumber, imageRangeCol).Value
If imageSource = "NAMED RANGE" Then
'Named Range
Set iName = dataWB.Names(imageRangeName)
Set iRange = iName.RefersToRange
Else
'Unnamed Range
Set iRange = imageWS.Range(imageRangeName)
End If
End If
'Image File Name
If imageSource = "NAMED RANGE" Or imageSource = "UNNAMED RANGE" Then
imageFileName = iRange.Value
Else
imageFileName = appWS.Cells(rowNumber, imageNameCol).Value
End If
If imageLocType = "LOCAL FOLDER" Then
ImageFileFullName = imageFolderName & "\" & imageFileName & "." &
LCase(imageType)
Else
ftpFileFullName = tempFolder & "\" & imageFileName & "." &
LCase(imageType)
End If
'PUBLISH !!!
If dataType = "NAMED RANGE" Or dataType = "UNNAMED RANGE" Then
'Named Range or Unnamed Range
rangeWidth = dRange.Width + 6 'adjustment for gridlines
rangeHeight = dRange.Height + 4 'adjustment for gridlines
Set imageContainerWS = ThisWorkbook.Worksheets(3)
Set imageContainer = imageContainerWS.ChartObjects("ImageContainer")
widthScale = rangeWidth / imageContainer.Width
heightScale = rangeHeight / imageContainer.Height
imageContainer.Activate
imageContainerWS.Shapes("ImageContainer").ScaleWidth widthScale, _
msoFalse, _
msoScaleFromTopLeft
imageContainerWS.Shapes("ImageContainer").ScaleHeight heightScale, _
msoFalse, _
msoScaleFromTopLeft
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = True 'Need this for image to be correctly
sized
'++++++++++++++++++++++++++++++++++++++++
dRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++
ActiveChart.Paste
On Error GoTo RangeExportError
If imageLocType = "LOCAL FOLDER" Then
ActiveChart.Export filename:=ImageFileFullName, _
filtername:=imageType
Else
ActiveChart.Export filename:=ftpFileFullName, _
filtername:=imageType
End If
On Error GoTo 0
ActiveChart.Pictures(1).Delete
appWS.Activate
GoTo Finish
RangeExportError:
ActiveChart.Pictures(1).Delete
appWS.Activate
GoTo ChartExportError 'share same message
Else
'Chart Object
Set instance = GetObject(dataWB.FullName).Application
instance.Workbooks(dataWB.Name).Worksheets(dataWS.Name).ChartObjects(dataChartName).Activate
On Error GoTo ChartExportError
If imageLocType = "LOCAL FOLDER" Then
instance.ActiveChart.Export filename:=ImageFileFullName, _
filtername:=imageType
Else
instance.ActiveChart.Export filename:=ftpFileFullName, _
filtername:=imageType
End If
On Error GoTo 0
Set instance = Nothing
End If
GoTo Finish
ChartExportError:
eMessage = "ERROR: Export failed"
Finish:
If weOpenedWB = True And closeIfOpened = True Then CloseWorkbook
If imageLocType = "FTP SITE" Then
If PutToFTP(imageftpSiteName, imageUsername, imagePassword,
imageFolderName, ftpFileFullName) = False Then
eMessage = "ERROR: ftp transfer failed"
End If
End If
Call SaveMessage(rowNumber, eMessage)
If showMessages = True Then
If eMessage = okMessage Then
MsgBox (eMessage & ".")
Else
ShowError (eMessage & ".")
End If
End If
If eMessage = okMessage Then
Call SaveMessage(rowNumber, "Image upated") 'Clear error messages
TimeStamp (rowNumber)
PublishRow = True
Else
PublishRow = False
End If
'No need to adjust Screen Updating;
' CheckRow left OFF
' Calling Routine needs to turn ON
' (left off in case of multiple calls)
End Function
Sub PublishAll(ByVal showMessages As Boolean)
Dim checkString As String
Dim checkBoolean As Boolean
Dim lastRow As Long
Dim r As Long
Dim perfect As Boolean
Dim dataWBFullName As String
Dim dataWBShortName As String
Dim dataWB As Workbook
checkString = CheckColumns(showMessages)
If checkString <> "" Then
appWS.Unprotect
FatalError (checkString)
ProtectWS
Exit Sub
Else
'Clear any previous Fatal Error messages
appWS.Unprotect
appWS.Cells(1, 2).Value = ""
ProtectWS
End If
lastRow = appWS.UsedRange.Rows.Count
perfect = True
For r = rngHeader.Row + 2 To lastRow
'++++++++++++++++++++++++++++++++++++++++
Application.StatusBar = "Processing row " & (r - rngHeader.Row - 1) & "
of " & (lastRow - rngHeader.Row - 1) & "..."
'++++++++++++++++++++++++++++++++++++++++
checkBoolean = CheckRow(r, False, False)
'Leave workbook open for PublishRow, Do NOT show messages
If checkBoolean = False Then
perfect = False
If appWS.Cells(r, dataWBCol).Value <> appWS.Cells(r + 1,
dataWBCol).Value And _
weOpenedWB = True Then
'Close workbook (we won't be continuing to publish this row)
CloseWorkbook
End If
GoTo NextRow
Else
If appWS.Cells(r, dataWBCol).Value = appWS.Cells(r + 1,
dataWBCol).Value Then
checkBoolean = PublishRow(r, False, False)
'Leave workbook open if we opened it, Do NOT show messages
Else
checkBoolean = PublishRow(r, True, False)
'Close workbook if we opened it, Do NOT show messages
End If
If checkBoolean = False Then perfect = False
End If
NextRow:
Next
'++++++++++++++++++++++++++++++++++++++++
Application.StatusBar = False
'++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = True
'++++++++++++++++++++++++++++++++++++++++
If showMessages = True Then
If perfect = True Then
buttonPublishAll.BackColor = buttonGreen
Beep
Else
buttonPublishAll.BackColor = buttonRed
Buzz
End If
End If
End Sub
Sub ShowError(ByVal message As String)
Dim response As Integer
response = MsgBox(message, _
vbCritical, _
"Error!")
End Sub
Sub FatalError(ByVal message As String)
'Note: Protection needs to be handled by calling Sub
appWS.Cells(1, 2).Value = "Fatal Error occurred at " & _
Format(Date, "mm-dd-yyyy") & " " & _
Format(Time, "HH:MM:SS") & " : " & _
Replace(message, vbCr, " ")
End Sub
Sub SaveMessage(ByVal rowNumber As Long, ByVal message As String)
appWS.Cells(rowNumber, messageCol).Value = message
End Sub
Sub TimeStamp(ByVal rowNumber As Long)
appWS.Cells(rowNumber, dateCol).Value = Date
appWS.Cells(rowNumber, timeCol).Value = Time
End Sub
Sub StartWBList()
Dim lastRow, lastCol As Long
Dim wbName, wsName, rangeName, chartName As String
Dim nm As Name
Dim chrt As ChartObject
Dim currentWBCol As Long
Dim currentWSRow As Long
Dim currentRangeRow As Long
Dim currentChartRow As Long
Dim r As Long
Dim cell1, cell2, searchRange As Range
lastRow = appWS.UsedRange.Rows.Count
