I have a project where I need to extract a file from a zip, and then open that file. I had it working last week with the code:
With CreateObject("Shell.Application")
.Namespace("" & UnZippedFolder).copyhere .Namespace("" & ZipFolder & _
ZipFile).Items
End With
When I tried to run it this week, I got a bunch of errors as I tried to debug it.
I've moved from 'simple' (above) to 'as explicit as I can figure out' (below). I'm currently getting the error, "Object variable or With block variable not set." with the line selected that has '*' at the end. I can't figure out why this error is being thrown, or how to fix it.
Dim WeekNum As Integer
Dim ZipFolder As String
Dim ZipFile As String
Dim UnZippedFile As String
Dim UnZippedFolder As String
Dim objShell
Dim UZipFold
Dim ZipFoldAndFile
If Proceed = False Then Exit Sub
WeekNum = Workbooks("personal.xlsb").Sheets("Dates").Range("WeekNum").Value
ZipFolder = "\\server\path\" ' obfuscated because I must, sorry
ZipFile = "Prefix" & "Week" & WeekNum & " (xlsx 07 format).zip" ' change the 11 to the last 2 digits of the year!
UnZippedFolder = "\\server\path\" ' obfuscated, again, because I must
UnZippedFile = "Logging_11" & "Week" & WeekNum & " (xlsx 07 format).xlsx"
Set objShell = New Shell
UZipFold = objShell.Namespace("" & UnZippedFolder)
ZipFoldAndFile = objShell.Namespace("" & ZipFolder & ZipFile)
UZipFold.copyhere (objShell.Namespace("" & ZipFolder & ZipFile).Items) '*'
You must declare your paths or anything passed to the shell object as variants, not strings.
See here: http://www.rondebruin.nl/windowsxpunzip.htm
Related
I have a list of file names in a worksheet. I want to read a name, find the actual file, rename it and move on to the next name.
The 1st part, retrieving the name from the worksheet and modifying it to the new name is not a problem. The problem is assigning the new name to the file.
The Name function does not work because the files are on a different drive. I also tried Scripting.FileSystemObject.
The code runs but no change is made.
Here is the code I used...
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.GetFile(fOldName)
If Not Err = 53 Then 'File not found
'Rename file
f.Name = fNewName
End If
Did I make a code mistake I'm not seeing? Should I be using/doing something else?
Finding info on VBA and/or VB6 is getting pretty rare these days.
BTW. This is for Excel 2016.
Tks
If there was no misunderstanding...
FSO... it's bad in any case. It's just a bugsful API wrapper, written with a left chicken paw.
There are pure VB & API for more sophisticated cases.
No external libs & objects:
Public Sub sp_PrjFilMov()
Dim i As Byte
Dim sNam$, sExt$, sPthSrc$, sPthTgt$, sDir$
sPthSrc = "V:\"
sPthTgt = "R:\"
sNam = "Empty_"
sExt = ".dmy" ' dummy
For i = 1 To 5 ' create set of files for test
Call sx_CrtFil(i, sPthSrc, sNam, sExt)
Next
sDir = Dir(sPthSrc & "*" & sExt, vbNormal) ' lookup for our files ..
Do
'Debug.Print sDir
Select Case LenB(sDir)
Case 0
Exit Do ' *** EXIT DO
Case Else
Call sx_MovFil(sPthSrc, sDir, sPthTgt) ' .. & move them to another disk
sDir = Dir
End Select
Loop
Stop
End Sub
Private Sub sx_CrtFil(pNmb As Byte, pPth$, pNam$, pExt$)
Dim iFilNmb%
Dim sFilNam$
sFilNam = pPth & pNam & CStr(pNmb) & pExt
iFilNmb = FreeFile
Open sFilNam For Output As #iFilNmb
Close #iFilNmb
End Sub
Private Sub sx_MovFil(pPnmSrc$, pFnm$, pPthTgt$)
Dim sSrcPne$
sSrcPne = pPnmSrc & pFnm
'Debug.Print "Move " & sSrcPne & " --> " & pPthTgt
Call FileCopy(sSrcPne, pPthTgt & pFnm)
Call Kill(sSrcPne)
End Sub
'
I'm trying to pull text from a bunch of XML files into Word. I'm working from a list of files and have found that some of them don't actually exist in the folder. So, I'm using this function to check whether the files actually exist before opening them. But I'm still getting error 52 (Bad file name or number).
This is the function:
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
And this is the code I'm calling it from:
Sub PullContent()
Dim docList As Document
Dim docCombinedFile As Document
Dim objFileListTable As Table
Dim objRow As Row
Dim strContent As String
Dim strFileCode As String
'Code # for the current file. (Pulled in temporarily, output to the Word doc.)
Dim strFilename As String
'Name of XML file. Created based on strFileCode
Set docCombinedFile = Documents.Add
'The new doc which will list all warnings
Dim strXml As String
'String variable that holds the entire content of the data module
Dim strInvalidCodes
'String listing any invalid file codes. Displayed at the end.
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Documents.Open FileName:="C:\Users\kelly.keck\Documents\Triton MTS\IETMs - Test\IETMList.docx"
Set docList = Documents("IETMList.docx")
Set objFileListTable = docList.Tables(1)
For Each objRow In objFileListTable.Rows
strFileCode = objRow.Cells(4).Range.Text
strFileCode = Left(strFileCode, Len(strFileCode) - 2)
strFilename = strFileCode & ".xml"
strPath = "C:\Applications\xml\"
If FileThere(strPath & strFileCode) = True Then
'MsgBox (strPath & strFilename)
strXml = FSO.OpenTextFile(strPath & strFilename).ReadAll
Else
strInvalidCodes = strInvalidCodes & vbCr & strFileCode
End If
Next
MsgBox ("The following filenames were invalid: " & vbCr & strInvalidCodes)
End Sub
Getting this error seems to defeat the purpose of having a function to check if a file exists, but I'm not sure what's wrong with the function.
A bit late to the party, but this hasn't had an accepted answer yet.
I generally use this method to test if a file exists, and your code uses FileSystemObject already so could use that reference.
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I believe that you need to be sure that FileThere is actually returning the Boolean value you intend. It would be more reliable if you checked the Len property (the number of characters) or checked whether it actually returns the empty string.
The following is more verbose than absolutely necessary in order to make the logic clear. If you were to use Len, instead, then you'd check Len(Dir(FileName)) > 0
Function FileThere(FileName as String) as Boolean
Dim bFileExists as Boolean
If Dir(FileName) = "" Then
bFileExists = False
Else
bFileExists = True
End If
FileThere = bFileExists
End Function
I'm pulling my hair out on this one.
I put together some code for opening a file associated with records in our database. Newer data has full file paths stored as text in a separate table. Old data does not have a full file path but has enough details to assemble a working path in most cases.
My code checks to see if the older data fields are null and if they are proceed to the newer filepath.
The problem I'm having is with DLookup in the IF statement being stuck on the first file it was used on. No matter what I do, DLookup always returns the same result as the first time I ran the code. I'm stumped.
Private Sub btnOpenFile_Click()
Dim FacID As String
Dim FacIDShort As String
Dim CDID As String
Dim FileName As String
Dim FileURL As String
FacID = [FAC_ID]
FacIDShort = Left(FacID, 4)
On Error GoTo ErrHandler
If IsNull([CD_NUM]) Then ' Checks to see if old file path exists before trying new file path
FileURL = DLookup("[File_Path]", "tblFileDirectory", "[Drawing_ID]")
Application.FollowHyperlink (FileURL)
Else
CDID = [CD_NUM]
FileName = [FILENAME]
FileURL = ("\\SYSTEMXXX\" & FacIDShort & "\" & FacID & "\FILES\" & CDID & "\" & FileName)
Application.FollowHyperlink (FileURL)
End If
Exit Sub
ErrHandler:
LogError (FileURL)
MsgBox ("Error: " & FileURL & vbNewLine & "The URL Does Not Exist.")
End Sub
DLookup("[File_Path]", "tblFileDirectory", "[Drawing_ID]" should actually be more like DLookup("[File_Path]", "tblFileDirectory", "MyDrawingIdColumnInTable = MyDrawingIdToLookFor"
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 8 years ago.
Improve this question
I’d like to remove a node from my xml file using VBA in MS Project 2007.
Should be so easy but I can’t get it running.
Here is my XML
<config id="config" ConfigSaveDate="2011-03-31 21:32:55" ConfigSchemaVersion="1.02">
<Custom>
</Custom>
<Program>
<DateFormat>yyyy-mm-dd hh:mm:ss</DateFormat>
</Program>
<ProjectFile ProjectFileName="projectfile1.mpp">
<RevisionNumber>201</RevisionNumber>
<FileName>projectfile1.mpp</FileName>
<LastSaveDate>2011-03-23 16:45:19</LastSaveDate>
</ProjectFile>
<ProjectFile ProjectFileName="projectfile2bedeleted.mpp">
<RevisionNumber>115</RevisionNumber>
<FileName>projectfile2bedeleted.mpp</FileName>
<LastSaveDate>2011-03-31 21:12:55</LastSaveDate>
</ProjectFile>
<ProjectFile ProjectFileName="projectfile2.mpp">
<RevisionNumber>315</RevisionNumber>
<FileName>projectfile2.mpp</FileName>
<LastSaveDate>2011-03-31 21:32:55</LastSaveDate>
</ProjectFile>
</config>
Here is my VBA code
Function configProjListDelete(configPath As String, ProjFiles As Variant) As Integer
' This function shall delete <ProjectFile> tags from the config.xml
' and shall delete coresponding project xml files from HD
' It shall return number of deleted files
' configPath is the path to the xml folder
' ProjFiles is an array of file names of to be deleted files in above mentioned folder
Dim xml As MSXML2.DOMDocument
Dim RootElem As MSXML2.IXMLDOMElement
'Dim cxp1 As CustomXMLPart
Dim delNode As MSXML2.IXMLDOMNode ' XmlNode 'MSXML2.IXMLDOMElement
Dim fSuccess As Boolean
Dim ProjectFileList As MSXML2.IXMLDOMElement
Dim fn As Variant 'file name in loop
Dim i As Integer
Dim delCnt As Integer
If Not FileExists(configPath) Then
' given configFile doesn't exist return nothing
Debug.Print " iven config file doesn't exist. File: " & configPath
GoTo ExitconfigProjListDelete
End If
'TODO: Catch empty ProjectFiles
' Initialize variables
Set xml = New MSXML2.DOMDocument
On Error GoTo HandleErr
' Load the XML from disk, without validating it.
' Wait for the load to finish before proceeding.
xml.async = False
xml.validateOnParse = False
fSuccess = xml.Load(configPath)
On Error GoTo 0
' If anything went wrong, quit now.
If Not fSuccess Then
GoTo ExitconfigProjListDelete
End If
Set RootElem = xml.DocumentElement
Debug.Print "- " & xml.getElementsByTagName("ProjectFile").Length & " ProjectFiles in config."
i = 0
delCnt = 0
' Loop through all ProjectFiles
For Each ProjectFileList In xml.getElementsByTagName("ProjectFile")
' check if each project file name is one of the files to be deleted
For Each fn In ProjFiles
If fn = ProjectFileList.getElementsByTagName("FileName").NextNode.nodeTypedValue Then
Debug.Print fn & " shall be deleted"
' remove it from the document
' here I'm struggeling!
'#################################################
' How to delete the node <ProjectFile> and its childNodes?
Set delNode = ProjectFileList.ParentNode
xml.DocumentElement.RemoveChild (ProjectFileList) ' Error: 438 rough translation: "Object doesn't support this methode"
' This is all I've tried, but nothing works
'===========================================
'RootElem.RemoveChild (delNode)
'xml.RemoveChild (delNode)
'RootElem.RemoveChild (ProjectFileList.SelectSingleNode("ProjectFile"))
'ProjectFileList.ParentNode.RemoveChild (ProjectFileList.ChildNodes(0))
'Set objParent = datenode.ParentNode
'xmldoc.DocumentElement.RemoveChild (objParent)
'Set ProjectFileList = Empty
delCnt = delCnt + 1
End If
Next fn
i = i + 1
Next ProjectFileList
' Save XML File
If checkAppPath("Trying to update config file.") Then
xml.Save CustomProperty("XMTMLMonitoring_AppPath") & "\" & m2w_config("SubFolder") & "\" & m2w_config("SubFolderData") & "\" & m2w_config("XMLConfigFileName")
Debug.Print " - Config has been updated and saved."
Else
MsgBox "Config data not exported to web." & Chr(10) & "Folder: '" & CustomProperty("XMTMLMonitoring_AppPath") & "\" & m2w_config("SubFolder") & "\" & m2w_config("SubFolderData") & Chr(10) & "doesn't exist. ", vbOKOnly, HEADLINE
End If
Set xml = Nothing
configProjListDelete = delCnt
ExitconfigProjListDelete:
Exit Function
HandleErr:
Debug.Print "XML File reading error " & Err.Number & ": " & Err.DESCRIPTION
MsgBox "Error " & Err.Number & ": " & Err.DESCRIPTION
On Error GoTo 0
End Function
I’d be glad to get some help!
Do you know about XPath? From the painful looks of your code, you do not. Instead of using a long combination of barbaric DOM methods to access the node you need, you should save yourself a lot of pain and just use an XPath to access it in one line.
If I understand correctly what you're trying to do, then something like the following can replace your entire double loop, from i=0 to Next ProjectFileList:
For i = LBound(ProjFiles) To UBound(ProjFiles)
Set deleteMe = XML.selectSingleNode( _
"/config/ProjectFile[#ProjectFileName='" & ProjFiles(i) & "']")
Set oldChild = deleteMe.parentNode.removeChild(deleteMe)
Next i
where the thing in "quotes" is an XPath. Hope this helps.
As a side note, it seems inefficient, confusing, and error-prone to have a ProjectFileName attribute and a FileName element containing the exact same information in your XML file. What's up with that?
Hello Scripting Experts,
I have a log file on remote servers..
in remote servers c:\vb\text.log
I have included my remote systems in list.Txt like
server1
server2
below is the sample of log..
application working
[10/23/2012 working
[10/24/2012 nos appdown
error found you need to check this
Below is my Script.
Set Fso = CreateObject("Scripting.FileSystemObject")
Set InFile = fso.OpenTextFile("list.Txt")
Set out = fso.CreateTextFile("error.log")
Const ForReading = 1
Do While Not (InFile.atEndOfStream)
strComputer = InFile.ReadLine
today = Date()
Set fso = CreateObject("Scripting.FileSystemObject")
strFilePath = "\\" & strComputer & "\c$\vb\"
Set InputFile = fso.OpenTextFile(strFilePath & "text.log", 1)
Do While Not (InputFile.AtEndOfStream)
strLine = InputFile.ReadLine
If Left(line, Len(today)+1) = "[" & today Then
' line timestamped with today's date
If InStr(line, "nos") > 0 Then
' line contains "error"
out.WriteLine InStr & vbTab & strComputer
End If
End If
Loop
InputFile.close
Loop
out.Close
InFile.Close
Basically the above script should search from current date line only from the text.log file that is [10/24/2012 nos appdown. Then if found as "Nos" in the current date line.. then it should write to the error.log with computer Name.
In my case the output is not coming , however looks like it is searching for the string "Nos".
Kindly gail break me from this situation....
The bug is that you don't specify the explicit option. Like so,
option explicit
This will force VBScript to complain about nondeclared variables. By doing this, you easily can spot misspelled variable names. Delcare variables with dim statement, like so
dim Fso, out
Run the script again and see that you are using a non-existing and non-initialized variable in comparision:
strLine = InputFile.ReadLine ' Read stuff to strLine
If Left(line, Len(today)+1) = "[" & today Then ' ERROR. line has no value!
There are several issues with your adaptation of my script:
As was already pointed out by vonPryz this is the cause of the problem:
strLine = InputFile.ReadLine
If Left(line, Len(today)+1) = "[" & today Then
When you change a variable name from file to strFile you have to change every occurrence of that variable, not just the line where it's assigned.
out.WriteLine InStr & vbTab & strComputer
This line will also fail, because InStr is a function and you don't call it with the correct number of arguments.
today = Date()
This should not be inside a loop unless you expect the date to change during the script run and need to have the current date in every loop cycle.
Set fso = CreateObject("Scripting.FileSystemObject")
fso is instantiated at the beginning of the script. There's no need to re-instantiate it, especially not in each loop cycle. That's just a waste of resources.
Const ForReading = 1
There's no point in defining a constant when you're never using it.
Do While Not ...
Using Do Until ... would be easier to read and to understand.