Namaste!
i have written a vba script to read the file from client's FTP and its working fine on remote server, however when i try to run the same script on amazon workspace it's not able to read the number of files from root directory and giving 0 result. Any suggestions to make it work ?
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim ans As Integer
Dim oFTP As New FTP
If oFTP.OpenConnection(shtConfig.Range("FTP_ADDRESS"), shtConfig.Range("FTP_USER"), shtConfig.Range("FTP_PASSWORD")) = True Then
If rsFiles Is Nothing Then
Set rsFiles = oFTP.GetFileList(FilePath:=shtConfig.Range("FTP_FOLDER"), FilePattern:=shtConfig.Range("FTP_FILE"))
Else
ans = MsgBox("Do you want to refresh the file list?", vbYesNo + vbQuestion)
If ans = vbYes Then Set rsFiles = oFTP.GetFileList(FilePath:=shtConfig.Range("FTP_FOLDER"), FilePattern:=shtConfig.Range("FTP_FILE"))
End If
rsFiles.Filter = "Name LIKE '%" & Format(Target.Range.offset(0, -2), "YYYYMMDD_HHMM") & "%'"
rsFiles.Sort = "Modified DESC"
If rsFiles.RecordCount <> 0 Then
Call SnapFile(rsFiles("Name"), Target.Range.offset(0, -4), Target.Range.offset(0, -3))
Else
MsgBox "Cannot find file", vbExclamation
End If
Else
MsgBox oFTP.ErrorInfo, vbExclamation
End If
End Sub
Immediate window
? rsfiles.RecordCount
0
Related
I am trying to upload multiple files at once into an access database via the use of a button. However only one file will upload at a time.
When the button is clicked it calls a sub procedure. My code is below:
Private Sub btnImport_Click()
'Calls the procdure that imports raw files
Call Module1.ImportRawFiles
End Sub
Public Sub ImportRawFiles()
Dim oFileDiag As Office.FileDialog
Dim path As String: path = ""
Dim oFSO As New FileSystemObject
Dim FileSelected As Variant
Set oFileDiag = Application.FileDialog(msoFileDialogFilePicker) ''Picks file to import
oFileDiag.AllowMultiSelect = True ''Allows multiple files to be selected
oFileDiag.Title = "Please select the reports to upload"
oFileDiag.Filters.Clear
oFileDiag.Filters.Add "Excel Spreadsheets", "*.xlsx, *.xls" ''Only allows xlsx and xls file types to upload
If oFileDiag.Show Then
For Each FileSelected In oFileDiag.SelectedItems
Form_Homepage.txtFileName = FileSelected
Next
End If
If Nz(Form_Homepage.txtFileName, "") = "" Then
MsgBox "No files selected please select a file"
Exit Sub
End If
If oFileDiag.SelectedItems.Count > 0 Then path = oFileDiag.SelectedItems(1)
If Len(path) > 0 Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, oFSO.GetFileName(Form_Homepage.txtFileName), path, 1
MsgBox "The " & oFSO.GetFileName(Form_Homepage.txtFileName) & " file has been uploaded"
Else
MsgBox "File not found"
End If
Does anyone know why only one file is uploading?
You are looping through all selected files to assign Form_Homepage.txtFileName but then not doing anything else in that same loop:
If oFileDiag.Show Then
For Each FileSelected In oFileDiag.SelectedItems
Form_Homepage.txtFileName = FileSelected
Next
End If
So by end of the loop, the last selected file is assigned, ignoring all the others, then your later logic statements only perform on that one file.
One solution would be to move your action logic up to the same loop. So move your IF statements into the assignment loop, that way they operate on each iterative assignment of your variable.
Run-time error '52': Bad file name or number
I would like to ask for your help and suggestions as to why my code encounters a "run-time error '52': bad file name or number" when I am using a computer which do not really have access to the directory drive. I tried it on my personal computer and it showed the run-time error.
My code is working fine when I am using our company computers which have access to the directory drive. And it displays the message box "unable to access" if I try to change the folder name to make it inaccessible (for troubleshooting purposes).
What I am trying to do is actually display a message box just in case the computer used do not have any access to the directory.
I tried searching around, tried using "", 0, and vbNullString. But no success. Thank you in advance for any help.
'Check if all fields are filled up.
If Wbb.Sheets("Report").TextBox3.Value = "" Then
MsgBox "Please check missing data."
Else
'Check if drive is accessible, if not prompt a message
If Dir(filePath1, vbDirectory) = "" Then 'this is where the run-time error is pointing at
MsgBox "Unable to access drive. Please save file manually."
Exit Sub
Else
'Check if folders exists in drive. If does not exist, create folders.
If filePathCheck <> "" Then
aDirs = Split(filePathCheck, "\")
If Left(filePathCheck, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(filePathCheck, InStr(iStart, filePathCheck, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
Next i
End If
End If
Dir() throws an error if the left part of the directory does not exist. However the FileSystemObject simply returns False without throwing an error.
Public Function FolderExists(ByVal Path As String) As Boolean
With CreateObject("Scripting.FileSystemObject")
FolderExists = .FolderExists(Path)
End With
End Function
No reference the the Scripting.Runtime required.
Going off of what #Jeeped said in your comments, use Error Handling - [1] - [2] - [3]
On Error GoTo ErrHandler
Exit Sub
ErrHandler:
Select Case Err.Number
Case 52
MsgBox "~"
' Possibly pop up a save dialog if you desire
Err.Clear
Resume Next
Case Else
MsgBox "!"
Exit Sub
End Select
I am checking if a file is open or not that is a .txt file
Private Sub CommandButton1_Click()
Dim strFileName As String
' Full path and name of file.
strFileName = "D:\te.txt"
' Call function to test file lock.
If Not FileLocked(strFileName) Then
' If the function returns False, open the document.
MsgBox "not open"
Else
MsgBox "open"
End If
End Sub
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Error #" & Str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
It turns out .txt when opened using notepad doesn't lock the file, so it can not be known if a .txt file is open or not. And hence, if that .txt file is opened in Wordpad or Sakura, etc., your code should work or at least other code from the net should work.
I found that if a text file is opened using FileSystemObject, then the file is not locked and can still be edited by other users. As a potential workaround, you could make a file with a single bit to indicate when the other file is in use, and include checking that bit in your code. Here's my code as a rough example:
'FSO parameters
Const ForAppending = 8
Const ForReading = 1
Const ForWriting = 2
Sub WriteToFile()
Set fso = CreateObject("Scripting.FileSystemObject")
'Check the current lock bit (1 is locked, 0 is unlocked)
Set FileLock = fso.OpenTextFile("C:\FileLock.txt", ForReading)
Dim LockBit As Integer
LockBit = FileLock.ReadAll
FileLock.Close
'If the bit is 1 (file in use) then wait 1 second and try again (up to 10 times)
For try = 1 To 10
If LockBit = 1 Then
Application.Wait (Now + TimeValue("0:00:1"))
Set FileLock = fso.OpenTextFile("C:\FileLock.txt", ForReading)
LockBit = FileLock.ReadAll
FileLock.Close
Else: GoTo Line1 'when the bit is 0 (file available)
End If
If try = 10 Then
MsgBox "File not available"
Exit Sub
End If
Next try
Line1:
Call LockTheFile(fso, True) 'Change the lock bit to "1" to show the file's in use
Set WriteFile = fso.OpenTextFile("C:\WriteFile.txt", ForWriting)
'Do what you will with the file
MsgBox "Write Successful"
WriteFile.Close
Call LockTheFile(fso, False) 'Change the lock bit to "0" to show the file's available
End Sub
I made this sub separate to make the main code more streamlined
Sub LockTheFile(fso, SetLock As Boolean)
'Write "1" to a lock file to indicate the text file is in use, or "0" to indicate not in use
Set BitFile = fso.CreateTextFile("C:\FileLock.txt", True)
If SetLock = True Then
BitFile.WriteLine "1"
Else
BitFile.WriteLine "0"
End If
BitFile.Close
End Sub
I am encountering a run-time error while using IMAPI. The error:
Adding a file or folder would result in a result image having a size larger than the current configured limit.
It works great for anything that doesn't exceed the type of media in the optical drive, else I get the above.
I saw a post from A_J here that leans toward a possible solution in C#:
fileSystemImage.FreeMediaBlocks = int.MaxValue;
I am looking for help in writing the above, but in 2013 Excel VBA.
Below is a copy of what I'm using:
Option Explicit
Sub TestCDWrite()
Application.DisplayAlerts = False
Dim objDiscMaster As IMAPI2.MsftDiscMaster2
Dim objRecorder As IMAPI2.MsftDiscRecorder2
Dim DataWriter As IMAPI2.MsftDiscFormat2Data
Dim intDrvIndex As Integer
'The Object browser, but not intellisense, presents types for these, but they cannot be used in VBA
Dim stream As Variant
Dim FS As Variant
Dim Result As Variant
Dim FSI As Object
Dim strBurnPath As String
Dim strUniqueID As String
' *** CD/DVD disc file system types
Const FsiFileSystemISO9660 = 1
Const FsiFileSystemJoliet = 2
Const FsiFileSystemUDF102 = 4
'On Error GoTo TestCDWrite_Error
intDrvIndex = 0
strBurnPath = Worksheets("mphoi").Range("AF2")
' Create a DiscMaster2 object to connect to optical drives.
Set objDiscMaster = New IMAPI2.MsftDiscMaster2
' Create a DiscRecorder2 object for the specified burning device.
Set objRecorder = New IMAPI2.MsftDiscRecorder2
strUniqueID = objDiscMaster.Item(intDrvIndex)
objRecorder.InitializeDiscRecorder (strUniqueID)
' Create a DiscFormat2Data object and set the recorder
Set DataWriter = New IMAPI2.MsftDiscFormat2Data
DataWriter.Recorder = objRecorder
DataWriter.ClientName = "IMAPIv2 TEST"
' Create a new file system image object
Set FSI = New IMAPI2FS.MsftFileSystemImage
fsi.freemediablocks=int.maxvalue
' Import the last session, if the disc is not empty, or initialize
' the file system, if the disc is empty
If Not DataWriter.MediaHeuristicallyBlank Then
On Error Resume Next
FSI.MultisessionInterfaces = DataWriter.MultisessionInterfaces
If Err.Number <> 0 Then
MsgBox "Multisession is not supported on this disc", vbExclamation, "Data Archiving"
GoTo ExitHere
End If
On Error GoTo 0
MsgBox "Importing data from previous session ...", vbInformation, "Data Archiving"
FS = FSI.ImportFileSystem()
Else
FS = FSI.ChooseImageDefaults(objRecorder)
End If
' Add the directory and its contents to the file system
MsgBox "Adding " & strBurnPath & " folder to the disc...", vbInformation, "Data Archiving"
FSI.Root.AddTree strBurnPath, False
' Create an image from the file system image object
Set Result = FSI.CreateResultImage()
Set stream = Result.ImageStream
' Write stream to disc using the specified recorder
MsgBox "Writing content to the disc...", vbInformation, "Data Archiving"
DataWriter.Write (stream)
MsgBox "Completed writing Archive data to disk ", vbInformation, "Data Archiving"
ExitHere:
Exit Sub
'Error handling block
TestCDWrite_Error:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "TestCode.TestCDWrite"
End Select
Resume ExitHere
Application.DisplayAlerts = True
'End Error handling block
End Sub
I am trying to add a field using VBA to a table in a mdb file if the field does not exist. If I open the mdb file in Access, and run the VBA code, it works fine. However, if I clode Access, I will encounter 'Error 3265 : Item not found in this collection.' at 'With Access.Application.DBEngine(0)(0).TableDefs("Contract")' stage.
Thanks!
Here is my code:
Sub ResetDB()
Dim nlen As Long
MsgBox ("Select the Access Database using this browse button")
NewFN = Application.GetOpenFilename(FileFilter:="mdb.Files (*.mdb), *.mdb", Title:="Please select a file")
If NewFN = False Then
' They pressed Cancel
MsgBox "Try Again if database needs to be reset"
Application.DisplayAlerts = False
'ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
Else
ActiveWorkbook.Unprotect ("12345")
Sheets("Version").Visible = True
Worksheets("Version").Unprotect (strPW)
Range("Database").Value = NewFN
'On Error GoTo Failed ' I comment this line just to see where the error is
' following line is when the error occurs
With Access.Application.DBEngine(0)(0).TableDefs("Contract")
.Fields.Refresh
nlen = Len(.Fields("Industry_Type").Name)
If nlen > 0 Then Sheets("Instructions").Range("a1") = 1 ' do nothing
End
End With
Failed:
If Err.Number = 3265 Then Err.Clear ' Error 3265 : Item not found in this collection.
With Access.Application.DBEngine(0)(0).TableDefs("Contract")
.Fields.Append .CreateField("Industry_Type", dbLong)
End With
End
End If
End Sub
If the Access is closed, you will not be able to work on it.
You must open the MDB file:
Dim db As New Access.Application
db.OpenAccessProject filepath
The use db to retrieve the tables:
db.TableDefs....