Can't open workbook in excel 64 bit 2010 - but can in excel 2010 3


D

Darrell

I made a xlsm file that allows me to grab charts from excel pages and save
them as pictures in folder or on an ftp server.

It work just fine in 2007 and in 2010 32 bit.
However, in Excel 2010 64 bit it does not work. As it will not open the
workbook it keeps displaying the erro cannot find workbook. I am having this
problem in several different macros. I have researsched everywhere to find
out what piece of code I am not updating.

The two macros I use on this particular workbook are attached. Any help
would be greatly appreciated.

see subsequent 3 post do to posting size limitations for the 2 macros
 
Ad

Advertisements

D

Darrell

Here is macro 2

Module 2:
Option Private Module

#If VBA7 Then

Public Declare PtrSafe Function MessageBeep Lib "user32" _
(ByVal wType As Long) As Long

#Else

Public Declare Function MessageBeep Lib "user32" _
(ByVal wType As Long) As Long

#End If

Public Const MB_ICONASTERISK = &H40&
Public Const MB_ICONEXCLAMATION = &H30&
Public Const MB_ICONHAND = &H10&
Public Const MB_ICONINFORMATION = MB_ICONASTERISK
Public Const MB_ICONMASK = &HF0&
Public Const MB_ICONQUESTION = &H20&
Public Const MB_ICONSTOP = MB_ICONHAND

'Shell And Wait
'****************************************
'Runs a Shell command, and waits for it to finish before continuing

#If VBA7 Then

Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32"
(ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal _
dwProcessID As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal
hObject _
As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal _
dwMilliseconds As Long)

#Else

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal _
dwProcessID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject _
As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal _
dwMilliseconds As Long)

#End If

Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
Private Const WAIT_TIMEOUT = &H102

Public Sub ShellAndWait(PathName, Optional WindowStyle As _
VbAppWinStyle = vbMinimizedFocus, Optional bDoEvents As _
Boolean = False)

Dim dwProcessID As Long
Dim hProcess As Long

dwProcessID = Shell(PathName, WindowStyle)

If dwProcessID = 0 Then
Exit Sub
End If

hProcess = OpenProcess(SYNCHRONIZE, False, dwProcessID)

If hProcess = 0 Then
Exit Sub
End If

If bDoEvents Then
Do While WaitForSingleObject(hProcess, 100) = WAIT_TIMEOUT
DoEvents
Loop
Else
WaitForSingleObject hProcess, INFINITE
End If

CloseHandle hProcess

End Sub
 
D

Darrell

Module 2:
Option Private Module

#If VBA7 Then

Public Declare PtrSafe Function MessageBeep Lib "user32" _
(ByVal wType As Long) As Long

#Else

Public Declare Function MessageBeep Lib "user32" _
(ByVal wType As Long) As Long

#End If

Public Const MB_ICONASTERISK = &H40&
Public Const MB_ICONEXCLAMATION = &H30&
Public Const MB_ICONHAND = &H10&
Public Const MB_ICONINFORMATION = MB_ICONASTERISK
Public Const MB_ICONMASK = &HF0&
Public Const MB_ICONQUESTION = &H20&
Public Const MB_ICONSTOP = MB_ICONHAND

'Shell And Wait
'****************************************
'Runs a Shell command, and waits for it to finish before continuing

#If VBA7 Then

Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32"
(ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal _
dwProcessID As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal
hObject _
As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal _
dwMilliseconds As Long)

#Else

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal _
dwProcessID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject _
As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal _
dwMilliseconds As Long)

#End If

Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
Private Const WAIT_TIMEOUT = &H102

Public Sub ShellAndWait(PathName, Optional WindowStyle As _
VbAppWinStyle = vbMinimizedFocus, Optional bDoEvents As _
Boolean = False)

Dim dwProcessID As Long
Dim hProcess As Long

dwProcessID = Shell(PathName, WindowStyle)

If dwProcessID = 0 Then
Exit Sub
End If

hProcess = OpenProcess(SYNCHRONIZE, False, dwProcessID)

If hProcess = 0 Then
Exit Sub
End If

If bDoEvents Then
Do While WaitForSingleObject(hProcess, 100) = WAIT_TIMEOUT
DoEvents
Loop
Else
WaitForSingleObject hProcess, INFINITE
End If

CloseHandle hProcess

End Sub
 
D

Darrell

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
 
D

Darrell

Macro 1 Second Third

lastCol = -2

Set cell1 = wbWS.Cells(1, 1)

For r = rngHeader.Row + 2 To lastRow

wbName = appWS.Cells(r, dataWBCol).Value

If wbName <> "" Then

If lastCol < 0 Then

currentWBCol = 1

lastCol = 1

Else

Set cell2 = wbWS.Cells(1, currentWBCol)

Set searchRange = wbWS.Range(cell1, cell2)

If IsError(Application.Match(wbName, searchRange, 0)) Then

currentWBCol = lastCol + 3

Else

currentWBCol = Application.Match(wbName, searchRange, 0)

End If

End If

wbWS.Cells(1, currentWBCol).Value = wbName

wbWS.Cells(2, currentWBCol).Value = "*end*"

wbWS.Cells(2, currentWBCol + 1).Value = "*end*"

End If

Next

End Sub

Sub RefreshWorkbook()

Dim wbFullName, wbShortName As String

Dim cell1, cell2, searchRange As Range

Dim currentWBCol, currentRngRow, currentWSRow, currentChrtRow As Long

Dim rangeName As Name

Dim testRange As Range

Dim ws As Worksheet

Dim chrt As ChartObject

'Verify workbook exists

wbFullName = appWS.Cells(Selection.Row, dataWBCol).Value

On Error Resume Next

If Dir(wbFullName, vbDirectory) = "" Then

Call SaveMessage(Selection.Row, "ERROR: Cannot locate workbook")

buttonRefreshWB.BackColor = buttonRed

Buzz

Exit Sub

End If

On Error GoTo 0

'Check if the workbook is open

'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++

OpenWorkbook (wbFullName)

'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = True
'++++++++++++++++++++++++++++++++++++++++

If dataWB Is Nothing Then

Call SaveMessage(Selection.Row, "ERROR: Cannot open workbook")

buttonRefreshWB.BackColor = buttonRed

Buzz

Exit Sub

End If

'REFRESH !!!

Set cell1 = wbWS.Cells(1, 1)

Set cell2 = wbWS.Cells(1, wbWS.UsedRange.Columns.Count)

Set searchRange = wbWS.Range(cell1, cell2)

If IsError(Application.Match(wbFullName, searchRange, 0)) Then

currentWBCol = wbWS.UsedRange.Columns.Count + 1

Else

currentWBCol = Application.Match(wbFullName, searchRange, 0)

End If

wbWS.Cells(1, currentWBCol).Value = wbFullName

currentRngRow = 2

For Each rangeName In dataWB.Names

'Make sure the Name refers to a range, not a constant

Set testRange = Nothing

On Error Resume Next

Set testRange = rangeName.RefersToRange

On Error GoTo 0

If testRange Is Nothing Then

'Do nothing

Else

wbWS.Cells(currentRngRow, currentWBCol).Value = rangeName.Name

currentRngRow = currentRngRow + 1

End If

Next

wbWS.Cells(currentRngRow, currentWBCol).Value = "*end*"

currentChrtRow = 2

For Each ws In dataWB.Worksheets

wbWS.Cells(currentChrtRow, currentWBCol + 1).Value = ws.Name

For Each chrt In ws.ChartObjects

wbWS.Cells(currentChrtRow, currentWBCol + 2).Value = chrt.Name

currentChrtRow = currentChrtRow + 1

Next

wbWS.Cells(currentChrtRow, currentWBCol + 2).Value = "*end*"

currentChrtRow = currentChrtRow + 1

Next

wbWS.Cells(currentChrtRow, currentWBCol + 1).Value = "*end*"

If weOpenedWB = True Then CloseWorkbook

Call UpdateSelection(Selection)

buttonRefreshWB.BackColor = buttonGreen

Beep

End Sub

Sub UpdateSelection(ByVal Target As Range)

Dim wbName As String

Dim wsName As String

Dim cell1, cell2, searchRange As Range

Dim c As Long

Dim r As Long

Dim foundEnd As Boolean

Dim validationList As String

If Target.Rows.Count > 1 Or _
Target.Columns.Count > 1 Or _
Target.Row < ThisWorkbook.Worksheets(1).Range("_Header").Row + 2 Then

buttonRefreshWB.Visible = False

buttonCheckRow.Visible = False

buttonPublishRow.Visible = False

buttonClearRow.Visible = False

buttonBrowse.Visible = False

oldRow = Target.Row

Exit Sub

Else

If buttonRefreshWB.Height <> 21.75 Then 'button height can get messed up
if we insert rows

buttonRefreshWB.Height = 21.75

buttonCheckRow.Height = 21.75

buttonPublishRow.Height = 21.75

buttonClearRow.Height = 21.75

End If

If buttonBrowse.Height <> 15.75 Then buttonBrowse.Height = 15.75

If Target.Row <> oldRow Then

buttonRefreshWB.BackColor = vbButtonFace

buttonCheckRow.BackColor = vbButtonFace

buttonPublishRow.BackColor = vbButtonFace

'++++++++++++++++++++++++++++++++++++++++
appWS.Unprotect 'Added because Excel 2010 beta will not VISUALLY
move buttons
'++++++++++++++++++++++++++++++++++++++++

buttonRefreshWB.Top = Target.Top + Target.Height / 2 -
buttonRefreshWB.Height / 2

buttonCheckRow.Top = buttonRefreshWB.Top

buttonPublishRow.Top = buttonRefreshWB.Top

buttonClearRow.Top = buttonRefreshWB.Top

'++++++++++++++++++++++++++++++++++++++++
ProtectWS 'See note above
'++++++++++++++++++++++++++++++++++++++++

buttonRefreshWB.Visible = True

buttonCheckRow.Visible = True

buttonPublishRow.Visible = True

buttonClearRow.Visible = True

oldRow = Target.Row

End If

Select Case Target.Column

Case Is = dataWBCol

'++++++++++++++++++++++++++++++++++++++++
appWS.Unprotect 'Added because Excel 2010 beta will not VISUALLY
move buttons
'++++++++++++++++++++++++++++++++++++++++

buttonBrowse.Top = Target.Top + Target.Height / 2 -
buttonBrowse.Height / 2

buttonBrowse.Left = Target.Left + Target.Width

buttonBrowse.Visible = True

'++++++++++++++++++++++++++++++++++++++++
ProtectWS 'See note above
'++++++++++++++++++++++++++++++++++++++++

Case Is = imageFolderCol

If appWS.Cells(Target.Row, imageLocTypeCol).Value = "Local
Folder" Then

'++++++++++++++++++++++++++++++++++++++++
appWS.Unprotect 'Added because Excel 2010 beta will not VISUALLY
move buttons
'++++++++++++++++++++++++++++++++++++++++

buttonBrowse.Top = Target.Top + Target.Height / 2 -
buttonBrowse.Height / 2

buttonBrowse.Left = Target.Left + Target.Width

buttonBrowse.Visible = True

'++++++++++++++++++++++++++++++++++++++++
ProtectWS 'See note above
'++++++++++++++++++++++++++++++++++++++++

Else

buttonBrowse.Visible = False

End If

Case Is = imagePasswordCol

If appWS.Cells(Target.Row, imageLocTypeCol).Value = "ftp Site"
Then

'++++++++++++++++++++++++++++++++++++++++
appWS.Unprotect 'Added because Excel 2010 beta will not VISUALLY
move buttons
'++++++++++++++++++++++++++++++++++++++++

buttonBrowse.Top = Target.Top + Target.Height / 2 -
buttonBrowse.Height / 2

buttonBrowse.Left = Target.Left + Target.Width

buttonBrowse.Visible = True

'++++++++++++++++++++++++++++++++++++++++
ProtectWS 'See note above
'++++++++++++++++++++++++++++++++++++++++

Else

buttonBrowse.Visible = False

End If

Case Is = dataWSCol, dataRangeCol, dataChartCol, imageWSCol,
imageRangeCol

buttonBrowse.Visible = False

'Reset Data Validation

wbName = appWS.Cells(Target.Row, dataWBCol).Value

Set cell1 = wbWS.Cells(1, 1)

Set cell2 = wbWS.Cells(1, wbWS.UsedRange.Columns.Count)

Set searchRange = wbWS.Range(cell1, cell2)

If IsError(Application.Match(wbName, searchRange, 0)) Then Exit
Sub

Select Case Target.Column

Case Is = dataWSCol, imageWSCol

c = Application.Match(wbName, searchRange, 0) + 1

r = 2

validationList = ""

foundEnd = False

Do While foundEnd = False

If wbWS.Cells(r, c).Value = "*end*" Then

foundEnd = True

Else

If wbWS.Cells(r, c).Value <> "" Then

validationList = validationList &
wbWS.Cells(r, c).Value & ","

End If

End If

r = r + 1

Loop

If validationList = "" Then validationList = ","

appWS.Unprotect 'Cannot add validation if worksheet
is protected, _
even if the target cell is not
Locked!

With Selection.Validation

.Delete

.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=validationList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False

End With

ProtectWS

Case Is = dataRangeCol, imageRangeCol

c = Application.Match(wbName, searchRange, 0)

r = 2

validationList = ""

foundEnd = False

Do While foundEnd = False

If wbWS.Cells(r, c).Value = "*end*" Then

foundEnd = True

Else

If wbWS.Cells(r, c).Value <> "" Then

validationList = validationList &
wbWS.Cells(r, c).Value & ","

End If

End If

r = r + 1

Loop

If validationList = "" Then validationList = ","

appWS.Unprotect 'Cannot add validation if worksheet
is protected, _
even if the target cell is not
Locked!

With Selection.Validation

.Delete

.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=validationList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False

End With

ProtectWS

Case Is = dataChartCol

c = Application.Match(wbName, searchRange, 0) + 1

wsName = appWS.Cells(Target.Row, dataWSCol).Value

Set cell1 = wbWS.Cells(2, c)

Set cell2 = wbWS.Cells(wbWS.UsedRange.Rows.Count, c)

Set searchRange = wbWS.Range(cell1, cell2)

If IsError(Application.Match(wsName, searchRange, 0))
Then Exit Sub

c = c + 1

r = Application.Match(wsName, searchRange, 0) + 1

validationList = ""

foundEnd = False

Do While foundEnd = False

If wbWS.Cells(r, c).Value = "*end*" Then

foundEnd = True

Else

If wbWS.Cells(r, c).Value <> "" Then

validationList = validationList &
wbWS.Cells(r, c).Value & ","

End If

End If

r = r + 1

Loop

If validationList = "" Then validationList = ","

appWS.Unprotect 'Cannot add validation if worksheet
is protected, _
even if the target cell is not
Locked!

With Selection.Validation

.Delete

.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=validationList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False

End With

ProtectWS

Case Else

'Should never get here!

End Select

Case Else

buttonBrowse.Visible = False

End Select

End If

End Sub

Sub BrowseWorkbooks()

Dim oldWB, oldFolder As String

Dim newWB As Variant

Dim cell1, cell2, searchRange As Range

Dim lastCol As Long

oldWB = Selection.Value

'Point to last folder

oldFolder = ""

Do While InStr(oldWB, "\") > 0

oldFolder = oldFolder & Left(oldWB, InStr(oldWB, "\"))

oldWB = Mid(oldWB, InStr(oldWB, "\") + 1)

Loop

If Len(oldFolder) > 0 Then

On Error Resume Next

ChDrive (Left(oldFolder, 1))

ChDir (oldFolder)

On Error GoTo 0

End If

'Get file name

newWB = Application.GetOpenFilename("Microsoft Excel Files (*.xls; *.xlsx;
*.xlsm), (*.xls; *.xlsx; *.xlsm)", _
, _
"Select Excel Workbook:")

If newWB = False Then Exit Sub 'User cancelled

Selection.Value = newWB

Set cell1 = wbWS.Cells(1, 1)

lastCol = wbWS.UsedRange.Columns.Count

Set cell2 = wbWS.Cells(1, wbWS.UsedRange.Columns.Count)

Set searchRange = wbWS.Range(cell1, cell2)

'Add to the list of workbooks if not already there

If IsError(Application.Match(newWB, searchRange, 0)) Then

lastCol = 3 * Int((lastCol + 2) / 3) + 1

wbWS.Cells(1, lastCol).Value = newWB

wbWS.Cells(2, lastCol).Value = "*end*"

wbWS.Cells(2, lastCol + 1).Value = "*end*"

End If

End Sub

Sub BrowseImageFolders()

Dim initialFolder, oldFolder, newFolder As String

Dim fileDlg As FileDialog

Dim sItem As String

oldFolder = Selection.Value

initialFolder = "" 'Set Default

On Error Resume Next

If Not Dir(oldFolder, vbDirectory) = "" Then initialFolder = oldFolder

On Error GoTo 0

Set fileDlg = Application.FileDialog(msoFileDialogFolderPicker)

With fileDlg

.title = "Select Folder:"
.AllowMultiSelect = False

If Right(oldFolder, 1) = "\" Then

.InitialFileName = oldFolder

Else

.InitialFileName = oldFolder & "\"

End If

If .Show <> -1 Then GoTo NextCode

sItem = .SelectedItems(1)

End With

NextCode:

newFolder = sItem

Set fileDlg = Nothing

If newFolder = "" Then Exit Sub

Selection.Value = newFolder

End Sub

Sub CheckAll()

Dim lastRow As Long

Dim r As Long

Dim perfect As Boolean

If CheckColumns(True) <> "" Then Exit Sub

lastRow = appWS.UsedRange.Rows.Count

perfect = True

For r = rngHeader.Row + 2 To lastRow

'++++++++++++++++++++++++++++++++++++++++
Application.StatusBar = "Checking row " & (r - rngHeader.Row - 1) & " of
" & (lastRow - rngHeader.Row - 1) & "..."
'++++++++++++++++++++++++++++++++++++++++

If appWS.Cells(r, dataWBCol).Value = appWS.Cells(r + 1, dataWBCol).Value
Then

If CheckRow(r, False, False) = False Then perfect = False
' (Leave file open if we opened it)

Else

If CheckRow(r, True, False) = False Then perfect = False
' (Close file if we opened it)

End If

Next

'++++++++++++++++++++++++++++++++++++++++
Application.StatusBar = False
'++++++++++++++++++++++++++++++++++++++++

If perfect = True Then

buttonCheckAll.BackColor = buttonGreen

Beep

Else

buttonCheckAll.BackColor = buttonRed

Buzz

End If

End Sub

Function CheckRow(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 eMessage As String

Dim dataWBFullName, dataType, dataWSName, dataRangeName, dataChartName As
String

Dim imageLocType, imageftpSiteName, imageFolderName, imageUsername,
imagePassword As String

Dim imageType, imageSource, imageWSName, imageRangeName, imageFileName As
String

Dim f As Integer

Dim dataWS As Worksheet

Dim imageWS As Worksheet

Dim dataChart As ChartObject

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 okMessage As String

Dim testFolder As String

Dim x1, x2 As Integer

Dim folderPart As String

'****************************************

okMessage = "Row is OK"

eMessage = okMessage 'default (no errors)

'Verify workbook specified

dataWBFullName = appWS.Cells(rowNumber, dataWBCol).Value

If dataWBFullName = "" Then

eMessage = "ERROR: No value for 'Workbook'"

GoTo Finish

End If

'Verify data type specified

dataType = UCase(appWS.Cells(rowNumber, dataTypeCol).Value)

If dataType = "" Then

eMessage = "ERROR: No value for 'Data Type'"

GoTo Finish

End If

'Verify data type recognized

If dataType <> "NAMED RANGE" And _
dataType <> "UNNAMED RANGE" And _
dataType <> "CHART OBJECT" Then

eMessage = "ERROR: Invalid value for 'Data Type'"

GoTo Finish

End If

'Verify data worksheet specified

If dataType = "UNNAMED RANGE" Or dataType = "CHART OBJECT" Then

dataWSName = appWS.Cells(rowNumber, dataWSCol).Value

If dataWSName = "" Then

eMessage = "ERROR: No value for 'Worksheet'"

GoTo Finish

End If

End If

'Verify data range specified

If dataType = "NAMED RANGE" Or dataType = "UNNAMED RANGE" Then

dataRangeName = appWS.Cells(rowNumber, dataRangeCol).Value

If dataRangeName = "" Then

eMessage = "ERROR: No value for 'Range'"

GoTo Finish

End If

End If

'Verify chart name specified

If dataType = "CHART OBJECT" Then

dataChartName = appWS.Cells(rowNumber, dataChartCol).Value

If dataChartName = "" Then

eMessage = "ERROR: No value for 'Chart Name'"

GoTo Finish

End If

End If
 
Ad

Advertisements

D

Darrell

Macro 1 Third Third

'Verify image location type specified

imageLocType = UCase(appWS.Cells(rowNumber, imageLocTypeCol).Value)

If imageLocType = "" Then

eMessage = "ERROR: No value for 'Location Type'"

GoTo Finish

End If

'Verify image location type recognized

If imageLocType <> "LOCAL FOLDER" And _
imageLocType <> "FTP SITE" Then

eMessage = "ERROR: Invalid value for 'Location Type'"

GoTo Finish

End If

'Verify image ftp site name specified

If imageLocType = "FTP SITE" Then

imageftpSiteName = appWS.Cells(rowNumber, imageftpSiteCol).Value

If imageftpSiteName = "" Then

eMessage = "ERROR: No value for 'ftp Site Name'"

GoTo Finish

End If

End If

'Verify image folder specified

If imageLocType = "LOCAL FOLDER" Then

imageFolderName = appWS.Cells(rowNumber, imageFolderCol).Value

If Right(imageFolderName, 1) = "\" Then imageFolderName =
Left(imageFolderName, Len(imageFolderName) - 1)

If imageFolderName = "" Then

eMessage = "ERROR: No value for 'Folder'"

GoTo Finish

End If

End If

'Verify image username specified

If imageLocType = "FTP SITE" Then

imageUsername = appWS.Cells(rowNumber, imageUsernameCol).Value

If imageUsername = "" Then

eMessage = "ERROR: No value for 'Username'"

GoTo Finish

End If

End If

'Verify image password specified

If imageLocType = "FTP SITE" Then

imagePassword = appWS.Cells(rowNumber, imagePasswordCol).Value

If imagePassword = "" Then

eMessage = "ERROR: No value for 'Password'"

GoTo Finish

End If

End If

'Verify image password was not entered directly

If imageLocType = "FTP SITE" Then

If (Decode(imagePassword) Like "Type? Error") = True Then

eMessage = "ERROR: Password " & Decode(imagePassword)

GoTo Finish

End If

End If

'Verify image type specified

imageType = UCase(appWS.Cells(rowNumber, imageTypeCol).Value)

If imageType = "" Then

eMessage = "ERROR: No value for 'File Type'"

GoTo Finish

End If

'Verify image type recognized

If imageType <> "JPG" And _
imageType <> "GIF" And _
imageType <> "PNG" Then

eMessage = "ERROR: Invalid value for 'File Type'"

GoTo Finish

End If

'Verify file name source specified

imageSource = UCase(appWS.Cells(rowNumber, imageSourceCol).Value)

If imageSource = "" Then

eMessage = "ERROR: No value for 'File Name Source Type'"

GoTo Finish

End If

'Verify file name source recognized

If imageSource <> "NAMED RANGE" And _
imageSource <> "UNNAMED RANGE" And _
imageSource <> "MANUAL" Then

eMessage = "ERROR: Invalid value for 'File Name Source Type'"

GoTo Finish

End If

'Verify image worksheet specified

If imageSource = "UNNAMED RANGE" Then

imageWSName = appWS.Cells(rowNumber, imageWSCol).Value

If imageWSName = "" Then

eMessage = "ERROR: No value for 'File Name Worksheet'"

GoTo Finish

End If

End If

'Verify image range specified

If imageSource = "NAMED RANGE" Or imageSource = "UNNAMED RANGE" Then

imageRangeName = appWS.Cells(rowNumber, imageRangeCol).Value

If imageRangeName = "" Then

eMessage = "ERROR: No value for 'File Name Range'"

GoTo Finish

End If

End If

'Verify image file name specified

If imageSource = "MANUAL" Then

imageFileName = appWS.Cells(rowNumber, imageNameCol).Value

If imageFileName = "" Then

eMessage = "ERROR: No value for 'Manual File Name'"

GoTo Finish

End If

End If

'Verify unnamed data range

If dataType = "UNNAMED RANGE" Then

Set testRange = Nothing

On Error Resume Next

Set testRange = appWS.Range(dataRangeName)

On Error GoTo 0

If testRange Is Nothing Then

eMessage = "ERROR: Invalid value for 'Range'"

GoTo Finish

End If

End If

'Verify unnamed image range

If imageSource = "UNNAMED RANGE" Then

Set testRange = Nothing

On Error Resume Next

Set testRange = appWS.Range(imageRangeName)

On Error GoTo 0

If testRange Is Nothing Then

eMessage = "ERROR: Invalid value for 'File Name Range'"

GoTo Finish

End If

'Verify unnamed image range has only one cell

If testRange.Rows.Count > 1 Or testRange.Columns.Count > 1 Then

eMessage = "ERROR: The range in 'File Name Range' has more than one
cell"

GoTo Finish

End If

End If

'Verify image folder exists (if type is 'Local Folder')

If imageLocType = "LOCAL FOLDER" Then

On Error Resume Next

If Dir(imageFolderName, vbDirectory) = "" Then

On Error GoTo 0

eMessage = "ERROR: Cannot locate 'Local Folder'"

GoTo Finish

End If

End If

On Error GoTo 0

'Verify valid folder names (if type is 'ftp Site')
' Note: Not checking to see if it exists, just that it's valid
' We do this by creating the folders in the Temp folder, and trapping any
errors

If imageLocType = "FTP SITE" Then

If imageFolderName = "" Then GoTo FolderSuccess

If InStr(imageFolderName, "*") > 0 Then GoTo FolderError

If InStr(imageFolderName, "?") > 0 Then GoTo FolderError

If InStr(imageFolderName, "\\") > 0 Then GoTo FolderError

If Left(imageFolderName, 1) = "\" Then imageFolderName =
Mid(imageFolderName, 2)

If Right(imageFolderName, 1) = "\" Then imageFolderName =
Left(imageFolderName, Len(imageFolderName) - 1)

If imageFolderName = "" Then GoTo FolderError

testFolder = Environ("temp") & "\DataPublisher"

If Dir(testFolder, vbDirectory) = "" Then MkDir testFolder

On Error GoTo FolderError

If Dir(testFolder & "\" & imageFolderName, vbDirectory) <> "" Then GoTo
FolderSuccess

x1 = 1

Do While x1 <= Len(imageFolderName)

x2 = InStr(x1, imageFolderName, "\")

If x2 = 0 Then

x2 = Len(imageFolderName)

Else

x2 = x2 - 1

End If

folderPart = Mid(imageFolderName, x1, x2 - x1 + 1)

testFolder = testFolder & "\" & folderPart

On Error GoTo FolderError

If Dir(testFolder, vbDirectory) = "" Then MkDir testFolder

On Error GoTo 0

x1 = x2 + 2

Loop

GoTo FolderSuccess

FolderError:

On Error GoTo 0

eMessage = "ERROR: Invalid value for 'Folder'"

GoTo Finish

FolderSuccess:

End If

'Verify write access to image folder

If imageLocType = "LOCAL FOLDER" Then

f = FreeFile()

testFile = imageFolderName & "\ChartPublisherTest.txt"

On Error GoTo WriteError

Open testFile For Output As #f

Print #f, "Test"

Close f

Kill testFile

On Error GoTo 0

GoTo WriteOK

WriteError:

eMessage = "ERROR: Cannot write to Folder"

GoTo Finish

WriteOK:

End If

'Verify Manual image file name is valid

f = FreeFile()

On Error GoTo ImageFileError

testFile = Environ("temp") & "\" & imageFileName & ".txt"

Open testFile For Output As #f

Print #f, "Test"

Close f

Kill testFile

On Error GoTo 0

GoTo ImageFileOK

ImageFileError:

eMessage = "ERROR: Invalid value for 'Manual File Name'"

GoTo Finish

ImageFileOK:

'Verify workbook exists

On Error Resume Next

If Dir(dataWBFullName, vbDirectory) = "" Then

On Error GoTo 0

eMessage = "ERROR: Cannot locate Workbook"

GoTo Finish

End If

On Error GoTo 0

'Check if the workbook is open

'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++

tempWeOpenedWB = weOpenedWB 'because OpenWorkbook doesn't know if WE opened
the workbook _
before OpenWorkbook was called

OpenWorkbook (dataWBFullName)

If tempWeOpenedWB = True Then weOpenedWB = True 'if we opened the
workbook before _
OpenWorkbook was
called, need _
to know that

If dataWB Is Nothing Then

eMessage = "ERROR: Cannot open Workbook"

GoTo Finish

End If

'Verify named data range exists

If dataType = "NAMED RANGE" Then

Set testName = Nothing

On Error Resume Next

Set testName = dataWB.Names(dataRangeName)

On Error GoTo 0

If testName Is Nothing Then

eMessage = "ERROR: Invalid value for 'Range'"

GoTo Finish

End If

End If

'Verify named data range refers to range and not a constant

If dataType = "NAMED RANGE" Then

Set testRange = Nothing

On Error Resume Next

Set testRange = testName.RefersToRange

On Error GoTo 0

If testRange Is Nothing Then

eMessage = "ERROR: Name in 'Range' does not refer to a Range"

GoTo Finish

End If

End If

'Verify named image range exists

If imageSource = "NAMED RANGE" Then

Set testName = Nothing

On Error Resume Next

Set testName = dataWB.Names(imageRangeName)

On Error GoTo 0

If testName Is Nothing Then

eMessage = "ERROR: Invalid value for 'File Name Range'"

GoTo Finish

End If

End If

'Verify named image range refers to a range and not a constant

If imageSource = "NAMED RANGE" Then

Set testRange = Nothing

On Error Resume Next

Set testRange = testName.RefersToRange

On Error GoTo 0

If testRange Is Nothing Then

eMessage = "ERROR: Name in 'File Name Range' does not refer to a
Range"

GoTo Finish

End If

'Verify named image range has only one cell

If testRange.Rows.Count > 1 Or testRange.Columns.Count > 1 Then

eMessage = "ERROR: The range in 'File Name Range' has more than one
cell"

GoTo Finish

End If

End If

'Verify data worksheet exists

If dataType = "UNNAMED RANGE" Or dataType = "CHART OBJECT" Then

Set dataWS = Nothing

On Error Resume Next

Set dataWS = dataWB.Worksheets(dataWSName)

On Error GoTo 0

If dataWS Is Nothing Then

eMessage = "ERROR: Invalid value for 'Worksheet'"

GoTo Finish

End If

End If

'Verify image worksheet exists

If imageSource = "UNNAMED RANGE" Then

Set imageWS = Nothing

On Error Resume Next

Set imageWS = dataWB.Worksheets(imageWSName)

On Error GoTo 0

If imageWS Is Nothing Then

eMessage = "ERROR: Invalid value for 'File Name Worksheet'"

GoTo Finish

End If

End If

'Verify chart object exists

If dataType = "CHART OBJECT" Then

Set dataChart = Nothing

On Error Resume Next

Set dataChart = dataWS.ChartObjects(dataChartName)

On Error GoTo 0

If dataChart Is Nothing Then

eMessage = "ERROR: Invalid valuefor 'Chart Object'"

GoTo Finish

End If

End If

'Verify image file name from workbook is valid

If imageSource = "NAMED RANGE" Or imageSource = "UNNAMED RANGE" Then

If imageSource = "NAMED RANGE" Then

Set testRange = dataWB.Names(imageRangeName).RefersToRange

Else

Set testRange = imageWS.Range(imageRangeName)

End If

imageFileName = testRange.Value

If imageFileName = "" Then

eMessage = "ERROR: No file name found in the Range listed in 'File
Name Range'"

GoTo Finish

End If

f = FreeFile()

On Error GoTo wbImageFileError

testFile = Environ("temp") & "\" & imageFileName & ".txt"

Open testFile For Output As #f

Print #f, "Test"

Close f

Kill testFile

On Error GoTo 0

GoTo wbImageFileOK

wbImageFileError:

eMessage = "ERROR: Invalid file name found in the Range listed in 'File
Name Range'"

GoTo Finish

End If

wbImageFileOK:

Finish:

If weOpenedWB = True And closeIfOpened = True Then CloseWorkbook

Call SaveMessage(rowNumber, eMessage)

'Leave display of OK Message to calling routine
' (because if Publishing All, we don't want to display the 'Check OK'
message)

If showMessages = True And eMessage <> okMessage Then

ShowError (eMessage & ".")

End If

If eMessage = okMessage Then

CheckRow = True

Else

CheckRow = False

End If

'CALLING ROUTINE NEEDS TO TURN SCREEN UPDATING BACK ON !!!
' (left off in case of multiple calls)

End Function

Sub ShowHelp()

With frmHelp

.lblWhenToPublish.Visible = True

.lblWhatToPublish.Visible = False

.lblWhereToPublish.Visible = False

.lblWhereToPublish2.Visible = False

.lblLastMessage.Visible = False

.lblLastSuccessfulPublish.Visible = False

.fraMainButtons.Visible = False

.fraOtherButtons.Visible = False

.tglWhenToPublish.Value = True

.tglWhatToPublish.Value = False

.tglWhereToPublish.Value = False

.tglWhereToPublish2.Value = False

.tglLastMessage.Value = False

.tglLastSuccessfulPublish.Value = False

.tglMainButtons.Value = False

.tglOtherButtons.Value = False

.tglWhenToPublish.Locked = True

.tglWhatToPublish.Locked = False

.tglWhereToPublish.Locked = False

.tglWhereToPublish2.Locked = False

.tglLastMessage.Locked = False

.tglLastSuccessfulPublish.Locked = False

.tglMainButtons.Locked = False

.tglOtherButtons.Locked = False

.Show

End With

End Sub

Sub ShowTimer(ByVal status As String)

'Note: Protection needs to be handled by calling Sub

If UCase(status) = "ON" Then

buttonStartTimer.Enabled = False

buttonStopTimer.Enabled = True

rngUpdateMessage.Font.Color = &HFF

comboUpdateMethod.Visible = False

rngUpdateMethod.Value = comboUpdateMethod.Value

rngUpdateTime.Locked = True

rngTimerStatus.Value = "ON"

rngTimerStatus.HorizontalAlignment = xlCenter

Else

buttonStartTimer.Enabled = True

buttonStopTimer.Enabled = False

rngUpdateMessage.Font.Color = rngUpdateMessage.Interior.Color

rngUpdateMethod.Value = ""

comboUpdateMethod.Visible = True

rngUpdateTime.Locked = False

rngTimerStatus.Value = "Off"

rngTimerStatus.HorizontalAlignment = xlLeft

End If

End Sub

Sub GetPassword()

With frmPassword

.txtPassword1.Value = ""

.txtPassword2.Value = ""

.txtPassword1.SetFocus

.Show

If .Tag = vbCancel Then Exit Sub

appWS.Unprotect

appWS.Cells(Selection.Row, Selection.Column).Value =
Code(.txtPassword1.Value)

appWS.Protect

End With

End Sub

Function Code(ByVal inword As String) As String

Dim passKey As String

Dim fullKey As String

Dim outWord As String

Dim x As Integer

passKey = "doDgeasPen"

fullKey = passKey

Do While Len(fullKey) < Len(inword)

fullKey = fullKey & passKey

Loop

fullKey = Left(fullKey, Len(inword))

outWord = ""

For x = 1 To Len(inword)

outWord = outWord & Format(Asc(Mid(inword, x, 1)) Xor Asc(Mid(fullKey,
x, 1)), "00#")

Next

Code = outWord

End Function

Function Decode(ByVal inword As String) As String

Dim passKey As String

Dim fullKey As String

Dim outWord As String

Dim x As Integer

passKey = "doDgeasPen"

If Len(inword) = 0 Then

Decode = "Type1 Error"

Exit Function

End If

If Len(inword) Mod 3 <> 0 Then

Decode = "Type2 Error"

Exit Function

End If

For x = 1 To Len(inword)

If Asc(Mid(inword, x, 1)) < 48 Or Asc(Mid(inword, x, 1)) > 57 Then

Decode = "Type3 Error"

Exit Function

End If

Next

fullKey = passKey

Do While Len(fullKey) < Len(inword) / 3

fullKey = fullKey & passKey

Loop

fullKey = Left(fullKey, Len(inword) / 3)

outWord = ""

For x = 1 To Len(inword) / 3

outWord = outWord & Chr(Mid(inword, 3 * (x - 1) + 1, 3) Xor
Asc(Mid(fullKey, x, 1)))

Next

Decode = outWord

End Function

Function PutToFTP(ByVal ftpSite As String, _
ByVal username As String, _
ByVal password As String, _
ByVal foldername As String, _
ByVal filename As String) As Boolean

Dim tempFolder As String

Dim ftpScript As String

Dim ftpOutput As String

Dim f As Integer

Dim found As Boolean

Dim echoed As String

Dim x1, x2 As Integer

Dim folderPart As String

tempFolder = Environ("temp")

ftpScript = tempFolder & "\" & "ftpScript.txt"

ftpOutput = tempFolder & "\" & "ftpOutput.txt"

If Dir(ftpScript) <> "" Then Kill ftpScript

If Dir(ftpOutput) <> "" Then Kill ftpOutput

f = FreeFile()

Open ftpScript For Output As #f

Print #f, username
Print #f, password

If foldername <> "" Then

x1 = 1

Do While x1 <= Len(foldername)

x2 = InStr(x1, foldername, "/")

If x2 = 0 Then

x2 = Len(foldername)

Else

x2 = x2 - 1

End If

folderPart = Mid(foldername, x1, x2 - x1 + 1)

Print #f, "mkdir " & folderPart

Print #f, "cd " & folderPart

x1 = x2 + 2

Loop

End If

Print #f, "binary"
Print #f, "put " & Chr(34) & filename & Chr(34)
Print #f, "bye"

Close f

ShellAndWait "cmd /c ftp -s:" & Chr(34) & ftpScript & Chr(34) & " " & _
ftpSite & _
" >" & Chr(34) & ftpOutput & Chr(34), vbHide

f = FreeFile()

Open ftpOutput For Input As #f

found = False

Do While found = False

Input #f, echoed

If InStr(echoed, "ftp> put " & Chr(34) & filename & Chr(34)) > 0 Then
found = True

Loop

Input #f, echoed

Close f

Kill ftpScript

Kill ftpOutput

If InStr(echoed, "PORT command successful") > 0 Then

PutToFTP = True

Else

PutToFTP = False

End If

End Function

Sub ProtectWS()

Call appWS.Protect(password:="", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
UserInterfaceonly:=False, _
AllowFormattingCells:=False, _
AllowFormattingColumns:=False, _
AllowFormattingRows:=False, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=True, _
AllowSorting:=False, _
AllowFiltering:=False, _
AllowUsingPivotTables:=False)

End Sub

Sub ClearRow()

Dim rowNumber As Long

Dim response As Integer

rowNumber = Selection.Row

response = MsgBox("This will remove ALL data in this row from the table." &
vbCr & vbCr & _
"This operation can NOT be undone." & vbCr & vbCr & _
"OK to remove the data?", _
vbOKCancel + vbExclamation, _
"Warning!")

If response = vbCancel Then Exit Sub

appWS.Cells(rowNumber, 1).EntireRow.ClearContents

End Sub

Sub OpenWorkbook(ByVal wbFullName As String)

'Opens the named workbook and sets the variable 'dataWB' to this workbook _
(workbook may be open in this or another instance of Excel)

Dim instance As Excel.Application

Set dataWB = Nothing

On Error Resume Next

Set dataWB = Application.Workbooks(GetFileName(wbFullName))

On Error GoTo 0

If Not (dataWB Is Nothing) Then

'A workbook with the SAME NAME is open in THIS instance of Excel; is it
the RIGHT one?

If dataWB.FullName = wbFullName Then

'The RIGHT workbook is open in THIS instance of Excel

weOpenedWB = False

GoTo OpenWorkbookSuccess

End If

End If

If Not (dataWB Is Nothing) Then

'A DIFFERENT workbook with the SAME NAME is open in THIS instance of Excel

Set instance = Nothing

On Error Resume Next

Set instance = GetObject(wbFullName).Application

On Error GoTo 0

If instance Is Nothing Then

'The RIGHT workbook is not open ANYWHERE

On Error GoTo OpenWorkbookError 'JUST IN CASE

Set instance = CreateObject("Excel.Application")

Set dataWB = instance.Workbooks.Open(wbFullName)

On Error GoTo 0 'JUST IN CASE

weOpenedWB = True

GoTo OpenWorkbookSuccess

Else

'The RIGHT workbook is open in ANOTHER instance of Excel

On Error GoTo OpenWorkbookError 'JUST IN CASE

Set dataWB = instance.Workbooks(GetFileName(wbFullName))

On Error GoTo 0 'JUST IN CASE

weOpenedWB = False

End If

Else

'NO workbook with this name is open in THIS instance of Excel

On Error GoTo OpenWorkbookError 'JUST IN CASE

Set instance = GetObject(wbFullName).Application

On Error GoTo 0 'JUST IN CASE

Set dataWB = Nothing

On Error Resume Next

Set dataWB = Application.Workbooks(GetFileName(wbFullName))

On Error GoTo 0

If dataWB Is Nothing Then

'The RIGHT workbook is already open in ANOTHER instance of Excel

On Error GoTo OpenWorkbookError 'JUST IN CASE

Set dataWB = instance.Workbooks(GetFileName(wbFullName))

On Error GoTo 0 'JUST IN CASE

weOpenedWB = False

GoTo OpenWorkbookSuccess

Else

'The RIGHT workbook is NOW open in THIS instance of Excel

weOpenedWB = True

End If

End If

OpenWorkbookSuccess:

ThisWorkbook.Activate

Exit Sub

OpenWorkbookError:

'Should never really get here, but just in case:

Set instance = Nothing

Set dataWB = Nothing

End Sub

Sub CloseWorkbook()

Dim wbFullName As String

Dim instance As Excel.Application

wbFullName = dataWB.FullName

Set dataWB = Nothing

On Error Resume Next

Set dataWB = Application.Workbooks(GetFileName(wbFullName))

On Error GoTo 0

On Error GoTo CloseWorkbookError 'JUST IN CASE

If dataWB Is Nothing Then

'Workbook is open in ANOTHER instance of Excel _
(which we also need to close, since getting here means we started it)

Set instance = GetObject(wbFullName).Application

Set dataWB = instance.Workbooks(GetFileName(wbFullName))

instance.DisplayAlerts = False

dataWB.Close

'Don't need to turn DisplayAlerts back on, since we're closing the
instance anyway

instance.Close

Set instance = Nothing

Else

'Workbook is open in THIS instance of Excel

Application.DisplayAlerts = False

dataWB.Close

Application.DisplayAlerts = True

End If

'Not sure if we really need these next few lines, but just in case:

Set dataWB = Nothing

weOpenedWB = False

Exit Sub

CloseWorkbookError:

'Should never really get here, but just in case:

Exit Sub

End Sub

Sub Buzz()

Call MessageBeep(MB_ICONSTOP)

End Sub

Function GetPath(ByVal fullFileName As String)

'****************************************
'Returns the path portion of the passed full file name _
( path will not include the final backslash (\) )

'Notes:

' Returns an empty string if the passed full file name does not contain a
backslash (\)
'****************************************
'Variable declarations

Dim x As Long

Dim found As Boolean

'****************************************

x = Len(fullFileName)

found = False

Do While x > 0 And found = False

If Mid(fullFileName, x, 1) = "\" Then

found = True

Else

x = x - 1

End If

Loop

If found = False Then

GetPath = ""

Else

GetPath = Left(fullFileName, x - 1)

End If

End Function

Function GetFileName(ByVal fullFileName As String)

'****************************************
'Returns the file name only (without path) of the passed full file name

'Notes:

' Returns the passed full file name if it does not contain a backslash (\)

'****************************************
'Variable declarations

Dim x As Long

Dim found As Boolean

Dim filename As String

'****************************************

filename = fullFileName 'default value

x = Len(fullFileName)

found = False

Do While x > 0 And found = False

If Mid(fullFileName, x, 1) = "\" Then

found = True

filename = Mid(fullFileName, x + 1)

Else

x = x - 1

End If

Loop

GetFileName = filename

End Function

Sub ShowAbout(Optional ByVal wbName As String, Optional ByVal title As String)

'****************************************
'NEED TO USE 'CALL' WITH THIS SUB WHEN PASSING MORE THAN ONE PARAMETER
'****************************************
'Displays a message showing program title, version, and author
'
'wbName: The name of the workbook for which to get the version number; _
if empty, use ThisWorkbook
'
'title: The title to display in the window title; _
if empty, use wbName or ThisWorkbook (without version and file
extension)
'
'Tries to determine version number of the program by looking for '-v' at the
end of the _
workbook name; everything after the '-v' (minus the file extension) is
assumed to _
be the version number. If no version number is found, assigns '???'
'
'Author is assumed to be 'cadmann'
'****************************************
'Variable declarations

Dim version As String

Dim x As Long

Dim found As Boolean

Dim response As Integer

'****************************************

version = "???" 'default value

If wbName = "" Then wbName = ThisWorkbook.Name

'Strip off the file extension

x = Len(wbName)

found = False

Do While x > 0 And found = False

If Mid(wbName, x, 1) = "." Then

found = True

wbName = Left(wbName, x - 1)

Else

x = x - 1

End If

Loop

'Search for version number

x = Len(wbName) - 1

found = False

Do While x > 0 And found = False

If Mid(wbName, x, 2) = "-v" Then

found = True

version = Mid(wbName, x + 2)

Else

x = x - 1

End If

Loop

'Set the title

If title = "" Then

If found = True Then

title = Left(wbName, InStr(wbName, version) - 3)

Else

title = wbName

End If

End If

'Show About

response = MsgBox("Version " & version & vbCr & vbCr & "Created by cadmann", _
, _
title)

End Sub
 
Ad

Advertisements


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top