Hey my program checks for a zip file and copies it to another directory. However I stumbled upon "Run time error '91' object variable or With block variable not set" on oApp when I compiled it.
Sub UnZip(Fname As Variant)
Dim oApp As Object
Dim FileNameFolder As Variant
FileNameFolder = "P:\"
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
End Sub
What's the problem?
I'm using MS access 2010
.Copyhere works on folder objects.
Sub UnZip(Fname As Variant)
dim objShell
dim objFolder
set objShell = CreateObject("shell.application")
set objFolder = objShell.NameSpace("P:")
If not objFolder is nothing then
objFolder.CopyHere(Fname)
End If
End Sub
Fname must include both path and filename with extension.
Related
I'm trying to use a macro from MS Access that #masoud wrote for me here - Reopening recently closed instances of Excel
What do I need to do to have it run from MS Access? Code has been converted to the following to suit me:
Public Sub CloseAllExcel(Close1 As Boolean)
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim strPath As String
strPath = "C:\path.txt"
If Close1 Then
Dim fso as Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile as Object
Set oFile = FSO.CreateTextFile(strPath)
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
oFile.WriteLine Application.ActiveWorkbook.FullName
wb.Save
wb.Close
Next
oFile.Close
Set fso = Nothing
Set oFile = Nothing
xl.Quit
Set xl = Nothing
Loop
Exit Sub
Else
Dim FileNum As Integer
Dim DataLine As String
FileNum = FreeFile()
Open strPath For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
Workbooks.Open DataLine
Wend
Exit Sub
End If
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
The issues I have is that oFile.WriteLine Application.ActiveWorkbook.FullName is having a method or data member not found for the ActiveWorkbook. I'm a bit of a novice with this but I would have thought the code was good enough as is to work straight from MS Access. It works if run from Excel though.
Thanks for the help.
I am running a few modules of code in access and am writing data into
Excel. When I write the first time, data gets written properly. But again
when I try, the new data is written on top of the old data. What should I do to
insert a new sheet?
My existing code is
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Dim objSht As Excel.Worksheet
Dim objRange As Excel.Range
Set objexcel = CreateObject("excel.Application")
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
Set objSht = wbexcel.Worksheets("Sheet1")
objSht.Activate
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
objexcel.Workbooks.Add
Set wbexcel = objexcel.ActiveWorkbook
Set objSht = wbexcel.Worksheets("Sheet1")
End If
I think that the following code should do what you want. It's very similar to yours, except it uses the return values from the .Add methods to get the objects you want.
Public Sub YourSub()
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Set objexcel = CreateObject("excel.Application")
'This is a bad way of handling errors. We should'
'instead check for the file existing, having correct'
'permissions, and so on, and actually stop the process'
'if an unexpected error occurs.'
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
Set wbexcel = objexcel.Workbooks.Add()
End If
CopyToWorkbook wbexcel
EndSub
Private Sub CopyToWorkbook(objWorkbook As Excel.Workbook)
Dim newWorksheet As Excel.Worksheet
set newWorksheet = objWorkbook.Worksheets.Add()
'Copy stuff to the worksheet here'
End Sub
I'm using Access 2013. I have a list of images in a table. I then need to search through a set of folders (including sub folders), locate the images and copy them to a new directory. The table that contains the image names does not reference the file path.
What is the best way to achieve this? Is it possible to loop through the table and perform the search, or would I have break it down and manually locate each file and update a flag to say it exists, then go back and copy them?
Not sure how to do this but would appreciate any ideas.
Thanks.
For some import programs I had to manipulate files, create copies etc. and I created some functions to help process, you might find some use in them:
To create folder from VBA:
Public Function folderCreate(filePath As String) As Boolean
'define variables
Dim fsoFold As Object
'set file system object
Set fsoFold = CreateObject("Scripting.FileSystemObject")
If Not fsoFold.folderExists(filePath) Then
'check if folder exists
fsoFold.CreateFolder (filePath)
End If
folderCreate = True
Set fsoFold = Nothing
End Function
To check if folder exists:
Public Function folderExists(folderPath As String) As Boolean
'define variables
Dim fso As Object
'set file system object
Set fso = CreateObject("Scripting.FileSystemObject")
'check if file exists
If fso.folderExists(folderPath) Then
folderExists = True
Else
folderExists = False
End If
Set fso = Nothing
End Function
To check if file exists:
Public Function fileExists(filePath As String) As Boolean
'define variables
Dim fso As Object
'set file system object
Set fso = CreateObject("Scripting.FileSystemObject")
'check if file exists
If fso.fileExists(filePath) Then
fileExists = True
Else
fileExists = False
End If
Set fso = Nothing
End Function
Similar to this, use movefile to move it to new location.
fso.movefile strFullPath, strFullBackUp
EDIT: Following sub will go through given folder and list all JPG images - this code is just example how to find files, folders and how to recursively go through them.
Public Sub listImages(folderPath As String)
'define variables
Dim fso As Object
Dim objFolder As Object
Dim objFolders As Object
Dim objF As Object
Dim objFile As Object
Dim objFiles As Object
Dim strFileName As String
Dim strFilePath As String
Dim myList As String
'set file system object
Set fso = CreateObject("Scripting.FileSystemObject")
'set folder object
Set objFolder = fso.GetFolder(folderPath)
'set files
Set objFiles = objFolder.files
Set objFolders = objFolder.subfolders
'list all images in folder
For Each objFile In objFiles
If Right(objFile.Name, 4) = ".jpg" Then
strFileName = objFile.Name
strFilePath = objFile.Path
myList = myList & strFileName & " - " & strFilePath & vbNewLine
End If
Next
'go through all subflders
For Each objF In objFolders
'call same procedure for each subfolder
Call listImages(objF.Path)
Next
Debug.Print myList
Set objFolder = Nothing
set objFolders = Nothing
Set objFile = Nothing
set objF = Nothing
Set fso = Nothing
End Sub
I was running a recursive file search procedure, and my computer shut down. I know what directory the procedure stopped at, is there a way I can specify a start folder for a recursive file search? For example, let's say this is my structure
R:\
R:\Test\
R:\Test\Folder1\
R:\Test1\
R:\Test1\Folder1\
R:\Test2\
R:\Test2\Folder2\
if I wanted the recursive search to start at
R:\Test1\Folder1\
how would the procedure go?
Option Compare Database
Sub ScanTablesWriteDataToText()
Dim Fileout As Object
Dim fso As Object
Dim objFSO As Object
Dim accapp As Access.Application
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim colFiles As Collection
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objRegExp As Object
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Pattern = ".jpg"
objRegExp.IgnoreCase = True
Set colFiles = New Collection
RecursiveFileSearch "R:\", objRegExp, colFiles, objFSO
For Each f In colFiles
'do something
Next
Set objFSO = Nothing
Set objRegExp = Nothing
End Sub
Sub RecursiveFileSearch(ByVal targetFolder As String, ByRef objRegExp As Object, _
ByRef matchedFiles As Collection, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object
Dim objSubFolders As Object
Set objFolder = objFSO.GetFolder(targetFolder)
For Each objFile In objFolder.files
If objRegExp.test(objFile) Then
matchedFiles.Add (objFile)
End If
Next
Set objSubFolders = objFolder.Subfolders
For Each objSubfolder In objSubFolders
RecursiveFileSearch objSubfolder, objRegExp, matchedFiles, objFSO
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objSubFolders = Nothing
End Sub
I'd change your recursive sub to include two more parameters -- one for the folder you're trying to find, and a boolean to indicate whether or not it's been found:
Sub RecursiveFileSearch(ByVal targetFolder As String, ByRef objRegExp As Object, _
ByRef matchedFiles As Collection, ByRef objFSO As Object, _
ByVal startFolder As String, ByVal found As Boolean)
Dim objFolder As Object
Dim objFile As Object
Dim objSubFolders As Object
Set objFolder = objFSO.GetFolder(targetFolder)
If startFolder = "" Or found Then
For Each objFile In objFolder.files
If objRegExp.test(objFile) Then
matchedFiles.Add (objFile)
End If
Next
End If
Set objSubFolders = objFolder.Subfolders
For Each objSubFolder In objSubFolders
If objSubFolder = startFolder Then
found = True
End If
RecursiveFileSearch objSubFolder, objRegExp, matchedFiles, objFSO, _
startFolder, found
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objSubFolders = Nothing
End Sub
When you call it, it would be:
RecursiveFileSearch "R:\", objRegExp, colFiles, objFSO, "R:\Test1\Folder1\", false
You could short-cut this by running an (elegant) PowerShell
Dumps recursive JPG list to C:\temp\filename.csv
Sub Comesfast()
X2 = Shell("powershell.exe get-childitem ""C:\Test1\Folder1"" -recurse | where {$_.extension -eq "".jpg""} | Select-Object FullName| export-csv ""C:\temp\filename.csv"" ", 1)
End Sub
I have a function in an Access 2007 database, which has been working fine until my PC was upgraded to Office 2010. The procedure is below and the offending line is that where 'originalFolder' is set:
Function ExportToSharePoint()
Dim oFs As New FileSystemObject
Dim originalFolder As Folder
Dim destinationPath As String
Dim ofile As file
Dim XLApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim strFileName As String
Dim oFolder As String
oFolder = "//chs114file1/dovpasres/Public/Script/InfoCentre/Delays"
Set oFs = CreateObject("Scripting.FileSystemObject")
Set XLApp = New Excel.Application
Kill "K:\Public\Script\InfoCentre\Delays\*.xlk"
Set originalFolder = oFs.GetFolder(oFolder)
destinationPath = "https://companyname.sharepoint.com/PRR/Documents/"
For Each ofile In originalFolder.Files
strFileName = oFs.GetFileName(ofile)
Set xlwb = XLApp.Workbooks.Open(ofile)
xlwb.SaveAs (destinationPath + strFileName)
Next
xlwb.Close True
XLApp.Quit
Set xlwb = Nothing
Set XLApp = Nothing
End Function
The error I'm getting is:
Error 13: data type mismatch
I'm mystified as this is a string, as required?
The Microsoft documentation lists the GetFolder return type as being Folder, but I suspect your problem is being caused by mixing late binding (via CreateObject) with early binding (via the strongly-typed Folder variable).
Either import the reference to avoid the CreateObject call, or change the type to a variant, or perhaps object:
Dim originalFolder As variant