Remove Excel task from Task manager after running from Access using VBA - excel

I will now take the opportunity to ask here, I have really tried a lot of different way, but it seems that I am not able to be able to close the Excel task in task-manger, It hangs until I close Access completely, annoying, because I can not run two different jobs using Excel from Access. Second job will give me errors.
I have made some comments to where I still is able to get rid of Excel.
The purpose for the code is to run some query's and export data to excel and then lock the excel sheet so users only can fill in answers to the data.
Code:
Private Sub Command65_Click()
Dim r As Double
'On Error GoTo Error_Handler
Dim objExcel As Excel.Application
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
Dim dbs As DAO.Database
Dim rSt As DAO.Recordset
Set dbs = CurrentDb
Set rSt = CurrentDb.OpenRecordset("qry_VC_Confirmation")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
'objExcel.Quit ' at this point it still works to close again
'Set objExcel = Nothing ' at this point it will remove from task manager
Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet = objWorkbook.Worksheets(1)
'Set objWorkbook = Nothing ' can close still at this stage
'Set objWorksheet = Nothing ' can close still at this stage
'objExcel.Quit ' at this point it still works to close again ?
'Set objExcel = Nothing ' at this point it still will not remove from task manager
iFld = 0
irow = 1
For icol = 1 To (rSt.Fields.count)
objWorksheet.Cells(irow, icol) = rSt.Fields(iFld).Name
objWorksheet.Cells(irow, icol).Interior.ColorIndex = 1
objWorksheet.Cells(irow, icol).Font.ColorIndex = 2
objWorksheet.Cells(irow, icol).Font.Bold = True
iFld = iFld + 1
Next
'Set objWorkbook = Nothing '
'Set objWorksheet = Nothing '
'objExcel.Quit ' at this point it still works to close Excel again ?
'Set objExcel = Nothing ' at this point it will still remove from task manager
irow = 2
If Not rSt.BOF Then rSt.MoveFirst
Do Until rSt.EOF
iFld = 0
lRecords = lRecords + 1
For icol = 1 To (rSt.Fields.count)
objWorksheet.Cells(irow, icol) = rSt.Fields(iFld)
iFld = iFld + 1
Next
irow = irow + 1
rSt.MoveNext
Loop
r = irow - 1
Columns("A:F").EntireColumn.AutoFit
ActiveSheet.Protection.AllowEditRanges.Add Title:="Unprotected", Range:=Range("F2:F" & r)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="secret"
objWorkbook.SaveAs ("C:\Dropbox\VC_Confirmation.xlsx")
ExitSub:
Set objWorkbook = Nothing '
Set objWorksheet = Nothing '
objExcel.Quit ' at this point it still works to close excel again ?
Set objExcel = Nothing ' at this point it will **NOT** remove from task manager
Exit Sub
Error_Handler:
MsgBox Error$
Resume ExitSub
End Sub

In the comments you mentioned that you had reset your code (i.e. pressed the stop button). This means that the portion of your code that kills excel did not run, thus leaving an open session of excel. There is a small (possibly semantic) issue with your code, but I don't believe that's what was causing your issue. Regardless, you should properly shut down the application like this.
ExitSub:
If Not objWorksheet Is Nothing Then
set objWorksheet = Nothing
End If
' You have to check for the workbook's existence before
' you try to close something that isn't there. This avoids runtime errors.
' Since your error handler points you back here, this code always runs, so
' The workbook might not be open.
If Not objWorkbook Is Nothing Then
objWorkbook.close
Set objWorkbook = Nothing
End If
' Same goes for quitting the application
If Not objExcel Is Nothing Then
objExcel.Quit
Set objExcel = Nothing
End If
Exit Sub
Error_Handler:
' error handling code here
Resume ExitSub
End Sub

Columns("A:F").EntireColumn.AutoFit
Adding as an answer just in case. Fully qualify this with the worksheet name and try again. This same problem was a huge bother to me too. You have to qualify 100% of your references, no matter what. Also, be super careful about using With statements on ranges, worksheets etc. So change it to ObjWorksheet.Columns("A:F")... instead

Related

How do I close an Excel spreadsheet in VBA code?

I have the following routine below that is meant to open an Excel spreadsheet and then go row by row to import the results into a table that is passed in. It works fine but the problem is if I try to open that same spreadsheet a second time I get a message that the file is in use and I have to Ctrl-Alt-Del to shut down Excel before I can use it again. I thought that the Set mySheet=Nothing and Set xlApp=Nothing would release the file but apparently not. What more can I do to make sure that Access lets go of the Excel file? Thanks in advance!
Public Sub MakeTempTable(strFilePath As String, tablename As String)
Dim mySheet As Object
Dim xlApp As Object
Dim rs As DAO.Recordset
Dim sql As String
sql = "DELETE * FROM " & tablename
DoCmd.RunSQL sql
Set rs = CurrentDb.OpenRecordset(tablename)
Set xlApp = CreateObject("Excel.Application")
Set mySheet = xlApp.Workbooks.Open(strFilePath).Sheets(1)
xlApp.Visible = False
Set mySheet = xlApp.Sheets("Input")
Dim dRows As Double
dRows = 1
Dim dRow As Double, dCol As Double
dRow = 2
On Error GoTo ERR
Do
dCol = 1
rs.AddNew
If mySheet.cells(dRow, 3) = "" Then Exit Do
Do
If mySheet.cells(dRow, dCol).Value <> "_END_" Then
rs.Fields(dCol).Value = Nz(mySheet.cells(dRow, dCol).Value, "")
dCol = dCol + 1
Else
Exit Do
End If
Loop
rs.Update
dRow = dRow + 1
Loop
EXITSUB:
Set mySheet = Nothing
Set xlApp = Nothing
Exit Sub
ERR:
If ERR.Number = 3265 Then MsgBox "The species selected are incompatible. Canceling import.", vbCritical, "IMPORT ERROR"
GoTo EXITSUB
End Sub
Try using
xlApp.Quit
When you set xlApp to nothing you are only clearing the object within the procedure, you aren't doing anything to the actual Excel instance. All that setting XXX = nothing allows you to do is then reuse that object.
You will need to legally close the workbooks that are open as in
xlApp.Workbooks.Close
EXITSUB:
This will close the instances that are open.
Prior to this, kill all the instances or reboot your machine to clear all the instances that are open.

Excel VBA Code Race Condition Not Fixed by Wait, Sleep, DoEvents, etc

SOLVED! See the code below for the solution!
I have an Excel file containing multiple shape objects next to a series of text. I wrote a script to identify the location of each shape, identify how many cells to the right and down the text extends to, sets that as a range and then imports that into a chart object so I can save it as a .jpg.
The trouble is that between the creation of the chart and the pasting of the string there exists a Race Condition. If I step through the script it works fine, but as soon as I run it I get nothing but blank images.
I've tried Application.ScreenUpdating = True; Application.PrintCommunication = True; and DoEvents
I've also tried Application.Wait, but even having it wait ten seconds doesn't do the trick, when stepping through the code the chart is loaded in less than 2 seconds.
Recently I tried the kernel32 sleep method as well, and that doesn't seem to work either. Again, the amount of time I let the system sleep far exceeded my stepping. I also added all of the above methods between each line within the With statement (obviously not as a solution, but as a test) and that didn't work either..
At this point I'm completely at a loss.
If I place a stop at .Chart.Paste and then run the script (F5), and just keep hitting Run then the script works wonderfully. I just don't want users to have to sit there and hit run 600 times.
There are obvious redundancies written in between the creation of the chart and pasting of the text. This is all in the attempt at getting the code to work properly when run, and once a solution is found most of that code will be removed.
Option Explicit
Public Function ChartCheck() As String
ReCheckChart:
DoEvents
If ActiveWorkbook.ActiveSheet.ChartObjects.Count > 0 Then
GoTo ContinuePaste:
Else
GoTo ReCheckChart:
ContinuePaste:
End If
End Function
Public Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to Save the Images In"
.AllowMultiSelect = False
If .Show -1 Then GoTo NextCode:
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Private Sub DNImageExtraction_Click()
Dim fileName As String
Dim targetWorkbook As Excel.Workbook
Dim targetWorksheet As Excel.Worksheet
Dim saveLocation As Variant
Dim saveName As String
Dim targetShape As Shape
Dim workingRange As Excel.Range
Dim bottomRow As Long
Dim workingRangeWidth As Double
Dim workingRangeHeight As Double
Dim tempChart As ChartObject
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DNImageExtraction.AutoSize = False 'This is necessary to prevent the system I use from altering the font on the button
DNImageExtraction.AutoSize = True
DNImageExtraction.Height = 38.4
DNImageExtraction.Left = 19.2
DNImageExtraction.Width = 133.8
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")
Set targetWorkbook = Workbooks.Open(fileName)
Set targetWorksheet = targetWorkbook.ActiveSheet
saveLocation = GetFolder
For Each targetShape In targetWorksheet.Shapes
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)
saveName = workingRange.Text
If workingRange.Offset(0, 1).Value "" Then
If workingRange.Offset(1, 1).Value = "" Then
Set workingRange = Nothing
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
Else
bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
End If
workingRangeWidth = workingRange.Width
workingRangeHeight = workingRange.Height
End If
workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)
Application.ScreenUpdating = True
Application.PrintCommunication = True
DoEvents
Call ChartCheck
tempChart.Chart.Paste
Application.ScreenUpdating = False
tempChart.Chart.Export fileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
tempChart.Delete
Set tempChart = Nothing
Next
Application.Workbooks(targetWorkbook.Name).Close savechanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Any assistance in either a solution to the Race Condition, or re organizing the script to avoid the Race Condition altogether would be greatly appreciated.
(Code above was updated per suggestions made by Macro Man, and then re-modified once again to add in all previous suggestions on how to fix Race Condition issues after the changes were not effective.)
Consider using Application.OnTime which is good feature. It allows the scheduling of some code to be run at a certain time, most often one adds a few seconds to the current time.
Excel VBA is single-threaded and so there is no real synchronization but there is a message pump to keep order. The great thing about Application.OnTime is that it will not run despite being scheduled until the current graph of code has completed.
Because Application.OnTime uses the message pump as that is a FIFO structure it is possible to interleave the execution of code.
I think this might help here.
You can schedule a "hasItFinished" procedure which checks the existence of the shape/chart objects and if not re-schedules itself.
P.S. Can be a little tricky to debug, refactor as much code as possible outside of the procedure that you will schedule and unit test them separately. Please don't expect the lovely Edit,Debug and Continue flow that you normally get with VBA if you go down this path.
Try getting rid of the error handlers and labels, and working with objects directly instead of searching through workbook/worksheet collections. Also using meaningful variable names and proper indentation will help follow the code easily should you have any issues.
If your code works when stepping through, that usually suggests there is some issue with the use of ActiveWorkbook when workbooks are being opened/closed. Working with workbooks as objects allows us to overcome that problem because no matter if the workbook is active or not, we are always using the same instance of that workbook.
Private Sub DNImageExtraction_Click()
Dim fileName As String
Dim targetWorkbook As Excel.Workbook
Dim targetWorksheet As Excel.Worksheet
Dim saveLocation As Variant
Dim saveName As String
Dim targetShape As Shape
Dim workingRange As Excel.Range
Dim bottomRow As Long
Dim workingRangeWidth As Double
Dim workingRangeHeight As Double
Dim tempChart As ChartObject
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")
Set targetWorkbook = Workbooks.Open(fileName)
Set targetWorksheet = targetWorkbook.ActiveSheet
saveLocation = GetFolder
For Each targetShape In targetWorksheet.Shapes
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)
saveName = workingRange.Text
If workingRange.Offset(0, 1).value <> "" Then
If workingRange.Offset(1, 1).value = "" Then
Set workingRange = Nothing
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
Else
bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
End If
workingRangeWidth = workingRange.Width
workingRangeHeight = workingRange.Height
End If
workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)
With tempChart
.Chart.Paste
.Chart.Export FileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
.Delete
End With
Set tmpChart = Nothing
DoEvents
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Excel keeps "running" while asking SAP GUI to export spreadsheet

I have a problem with a Excel VBA code that constantly get stuck in 'running' when I execute the code, see figure
The Purpose of the code is:
Log into SAP
Execute a transaction (in this case IW73)
Export a Spreadsheet as .txt
The Problem after closing the SAP session the Excel get stuck in "Running". We have tried running it on different computers with the same (Stuck in 'Running') error.
Code:
Sub Logontrial()
Dim SapGuiApp As Object
Dim oConnection As Object
Dim SAPCon As Object, SAPSesi As Object
Dim SapGuiAuto As Object, SAPApp As Object
If SapGuiApp Is Nothing Then
Set SapGuiApp = CreateObject("Sapgui.ScriptingCtrl.1")
End If
If oConnection Is Nothing Then
Set oConnection = SapGuiApp.OpenConnection("5.1.1 AP1 ERP Production", True)
End If
If SAPSesi Is Nothing Then
Set SAPSesi = oConnection.Children(0)
End If
Application.DisplayAlerts = False
With SAPSesi
SAPSesi.findById("wnd[0]/usr/txtRSYST-MANDT").Text = "500"
SAPSesi.findById("wnd[0]/usr/txtRSYST-BNAME").Text = "UserName"
SAPSesi.findById("wnd[0]/usr/pwdRSYST-BCODE").Text = "Password"
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").Text = "EN"
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").SetFocus
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").caretPosition = 2
SAPSesi.findById("wnd[0]").sendVKey 0
' start extraction
On Error GoTo Resume1
' DoEvents
SAPSesi.findById("wnd[0]").maximize
SAPSesi.findById("wnd[0]/tbar[0]/okcd").Text = "/nIW73"
SAPSesi.findById("wnd[0]").sendVKey 0
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").Text = "GB10"
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").SetFocus
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").caretPosition = 4
SAPSesi.findById("wnd[0]").sendVKey 8
SAPSesi.findById("wnd[0]").sendVKey 0
SAPSesi.findById("wnd[0]/mbar/menu[0]/menu[11]/menu[2]").Select
SAPSesi.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").Select
SAPSesi.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").SetFocus
SAPSesi.findById("wnd[1]/tbar[0]/btn[0]").press
SAPSesi.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = "DataImport1.txt"
SAPSesi.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 15
SAPSesi.findById("wnd[1]/tbar[0]/btn[11]").press
SAPSesi.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
SAPSesi.findById("wnd[0]").sendVKey 0
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
End With
' This part after closing the SAP session it get stuck.
Resume1:
Application.DisplayAlerts = True
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
Exit Sub
End Sub
Thanks in advance
//Patrick
Disclaimer: This is not quality code, and most probably one day someone can put some bunch of hate towards you.
Before finding something better, try the following, it should work. Simply write End here:
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
End
Then look for a better solution.

TableStyle with VBScript

Is there any way to Style a table with VBScript? All the solutions I'm finding online are for VBA.
for example, I tried the solution here Excel Macro - Select all cells with data and format as table with the following code
Set objExcel = CreateObject("Excel.Application")
Dim tbl
Set tbl = objWorkbook.ListObjects.Add(xlSrcRange, objWorkbook.Sheets("101").Range("$A$1:$C$26"), , xlYes)
tbl.TableStyle = "TableStyleLight1"
but I get this error
Microsoft VBScript runtime error: Object doesn't support this property or method: 'objWorkbook.ListObjects'
(If you have a solution for this in exceljs that would be even better)
I found something you may be able to use. It is from Using Styles to Dress Up Your Worksheets in Excel 2007. What I did was converted it from VBA to VBScript, which really wasn't that hard.
Sub ListStyles()
Dim objStyle
Dim objCellRange
Dim lngCount
Dim objSheet
Set objSheet = ThisWorkbook.Worksheets("Config - Styles")
With objSheet
lngCount = objSheet.UsedRange.Rows.Count + 1
For Each objStyle In ThisWorkbook.Styles
On Error Resume Next
Set objCellRange = Nothing
Set objCellRange = Intersect(objSheet.UsedRange, objSheet.Range("A:A")).Find(objStyle.Name, _
objSheet.Range("A1"), xlValues, xlWhole, , , False)
If objCellRange Is Nothing Then
lngCount = lngCount + 1
.Cells(lngCount, 1).Style = objStyle.Name
.Cells(lngCount, 1).Value = objStyle.NameLocal
.Cells(lngCount, 2).Style = objStyle.Name
End If
Next
End With
End Sub
To set this up, double click on the Sheet1 tab and rename it "Config - Styles". Add the code above, then run the script. What you end up with is this:

Macro in PowerPoint which links to data stored in an Excel Spreadsheet

I have an Excel Spreadsheet (let's say objectdata.xls) which is used to set the widths/lengths of different rectangles. The spreadsheet therefore has 3 columns:
Object Name
Object Width
Object Length
There are approx 100 rectangles defined in the Spreadsheet
What i am try to do is run a macro in a PowerPoint (PP) which will read the data from the Spreadsheet (ideally this info should be stored external to the PP file but if need be it could be a linked or embedded file within PP) and then update the size of the rectangle shapes that I have included in the PP file.
E.g. on slide one, the macro reads row 1 in the spreadhseet and sees that the object width is 5 and length is 10, and so updates the size of the rectangle shape in the PP.
Can anyone tell me if this can be done?
Thanks.
Use GetExcelData to do the work; it calls GetExcel
Function GetExcel() As Object
'---------------------------------------------------------------------------------------
' Procedure : GetExcel
' Author : Naresh Nichani / Steve Rindsberg
' Purpose :
' Check if an instance of Excel is running. If so obtain a reference to the running Excel application
' Otherwise Create a new instance of Excel and assign the XL application reference to oXLApp object
' SR : Modified 2010-02-23 to ALWAYS create a new instance rather than using an existing one, so when we
' : close the one we open, we don't wack the user's other instances of Excel if any
' Params : None
' Returns : An Excel Application object on success, Nothing on failure
'---------------------------------------------------------------------------------------
On Error GoTo GetExcel_ErrorHandler
On Error Resume Next
Err.Number = 0
Dim oXLAPP As Object
' Comment out the following bits to force a new instance of Excel
' and leave any existing instances alone
' Set oXLApp = GetObject(, "Excel.Application")
' If Err.Number <> 0 Then
' Err.Number = 0
Set oXLAPP = CreateObject("Excel.Application")
If Err.Number <> 0 Then
'MsgBox "Unable to start Excel.", vbInformation, "Start Excel"
Exit Function
End If
' End If
On Error GoTo GetExcel_ErrorHandler
If Not oXLAPP Is Nothing Then
Set GetExcel = oXLAPP
Else
[MASTTBAR].rnrErrLog "modExcel:GetExcel - unable to invoke Excel instance"
End If
Set oXLAPP = Nothing
Exit Function
NormalExit:
On Error GoTo 0
Exit Function
GetExcel_ErrorHandler:
Resume NormalExit
End Function
Function GetExcelData(sFilename As String, _
Optional lWorksheetIndex As Long = 1, _
Optional sWorksheetName As String = "") As Variant
'---------------------------------------------------------------------------------------
' Purpose : Gets the "active" data from the file/worksheet specified
Dim oXLAPP As Object
Dim oxlWB As Object
Dim oxlRange As Object
Dim x As Long
Dim y As Long
Dim sMsg As String
Dim lVisibleRowCount As Long
Dim lVisibleColCount As Long
Dim aData() As String
On Error GoTo GetExcelData_ErrorHandler
Set oXLAPP = GetExcel()
If oXLAPP Is Nothing Then
Exit Function
End If
' open the workbook read-only
Set oxlWB = oXLAPP.Workbooks.Open(sFilename, , True)
If oxlWB Is Nothing Then
Exit Function
End If
If Len(sWorksheetName) > 0 Then
Set oxlRange = GetUsedRange(oxlWB.Worksheets(sWorksheetName))
Else
Set oxlRange = GetUsedRange(oxlWB.Worksheets(lWorksheetIndex))
End If
If oxlRange Is Nothing Then
Exit Function
End If
' Get a count of visible rows/columns (ignore hidden rows/cols)
For x = 1 To oxlRange.Rows.Count
If Not oxlRange.Rows(x).Hidden Then
lVisibleRowCount = lVisibleRowCount + 1
End If
Next ' row
For y = 1 To oxlRange.Columns.Count
If Not oxlRange.Columns(y).Hidden Then
lVisibleColCount = lVisibleColCount + 1
End If
Next
ReDim aData(1 To lVisibleRowCount, 1 To lVisibleColCount)
lVisibleRowCount = 0
For x = 1 To oxlRange.Rows.Count
If Not oxlRange.Rows(x).Hidden Then
lVisibleRowCount = lVisibleRowCount + 1
lVisibleColCount = 0
For y = 1 To oxlRange.Columns.Count
If Not oxlRange.Columns(y).Hidden Then
lVisibleColCount = lVisibleColCount + 1
aData(lVisibleRowCount, lVisibleColCount) = oxlRange.Cells(x, y).Text
End If
Next
End If
Next
' return data in array
GetExcelData = aData
NormalExit:
On Error GoTo 0
' Close the workbook
If Not oxlWB Is Nothing Then
oXLAPP.DisplayAlerts = False
oxlWB.Close
oXLAPP.DisplayAlerts = True
End If
'To Close XL application
If Not oXLAPP Is Nothing Then
oXLAPP.Quit
End If
'Set the XL Application and XL Workbook objects to Nothing
Set oxlRange = Nothing
Set oxlWB = Nothing
Set oXLAPP = Nothing
Exit Function
GetExcelData_ErrorHandler:
Resume NormalExit
End Function
Blockquote
Blockquoteenter code here
Yes, this can certainly be done. It takes a bit more code than I have at the tip of my fingers and you'd need to adapt whatever I posted. But have a look here for examples you can start with. These point to the PowerPoint FAQ site that I maintain. No charge for anything.
Controlling Office Applications from PowerPoint (by Naresh Nichani and Brian Reilly)
http://www.pptfaq.com/FAQ00795.htm
Automate Excel from PowerPoint. Automate PowerPoint from Excel. And so on.
http://www.pptfaq.com/FAQ00368.htm
I'd probably do this by opening the excel file, reading the contents into an array, then using the data from the array to do the actual work in PPT.
If you need help with the PPT part, let us know. It'd mostly be a matter of writing a function like [aircode]:
Sub SetRectangleSize ( sRectangleName as string, sngWidth as Single, sngHeight as Single)
Dim oShp as Shape
Set oShp = GetShapeNamed(sRectangleName, lSlideIndex)
If Not oShp is Nothing Then
With oShp
.Width = sngWidth
.Height = sngHeight
End With
End If
End Sub
And
Function GetShapeNamed(sName as String, lSlideIndex as Long) as Shape
On Error Resume Next
Set GetShapeNamed = ActivePresentation.Slides(lSlideIndex).Shapes(sName)
If Err.Number <> 0 Then
' no shape by that name on the slide; return null
Set GetShapeNamed = Nothing
End If
End Function
Incidentally, I would consider using tags to identify the rectangles rather than shape names (which tend to be less reliable).

Resources