I've developed the following code to save all publisher files in the current directory as an image, however it seems to take a long time to run through. Also, I can't figure out a way to exclude the current file that the macro is running from. Anyone got any ideas?
Sub Looptest()
Dim MyFile As String, Sep As String
Dim objPub As Object
Set objPub = CreateObject("Publisher.Application")
Dim folder As String
folder = CurDir()
If Len(Dir(folder & "\" & "jpg", vbDirectory)) = 0 Then
MkDir (folder & "\" & "jpg")
End If
Sep = Application.PathSeparator
If Sep = "\" Then
' Windows platform search syntax.
MyFile = Dir(CurDir() & Sep & "*.pub")
Else
MyFile = Dir("", MacID("XLS5"))
End If
' Starts the loop, which will continue until there are no more files
' found.
Do While MyFile <> ""
'If MyFile = "macro.pub" Then
'GoTo ContinueLoop
'End If
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
Dim folder2 As String
folder2 = CurDir() & Sep & MyFile
Set pubApp = New Publisher.Application
pubApp.Open folder2
'pubApp.ActiveWindow.Visible = True
num = folder2
pubApp.ActiveDocument.Pages(1).SaveAsPicture CurDir() & Sep & "jpg" & "\" & MyFile & ".jpg"
pubApp.Quit
MyFile = Dir()
'ContinueLoop:
Loop
End Sub
I've commented out my attempt at skipping the file (called Macro.pub in this instance), as it just seemed to stall and not go anywhere.
Any help would be greatly appreciated!
-Cr1kk0
Assuming your code is correct in all other respects, this might do the trick
If MyFile = ActiveDocument.FullName Then
GoTo ContinueLoop
End If
I'm guessing your check fails because you're comparing a short file name to a full file name. (You could also just hardcode the entire path to macro.pub)
Related
I am currently trying to put a macro together to sort files into folders based on a filename. I am locked into using VBA due to the system we are on.
For example sorting just the excel documents from below present in C:\ :
123DE.xls
124DE.xls
125DE.xls
124.doc
123.csv
into the following folder paths:
C:\Data\123\Data Extract
C:\Data\124\Data Extract
C:\Data\125\Data Extract
The folders are already created, and as in the example are named after the first x characters of the file. Batches of 5000+ files will need to be sorted into over 5000 folders so im trying to avoid coding for each filename
I am pretty new to VBA, so any guidance would be much appreciated. So far I have managed to move all the excel files into a single folder, but am unsure how to progress.
Sub MoveFile()
Dim strFolderA As String
Dim strFolderB As String
Dim strFile as String
strFolderA = "\\vs2-alpfc\omgusers7\58129\G Test\"
strFolderb = "\\vs2-alpfc\omgusers7\58129\G Test\1a\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) >0
Name StrFolderA & strFile As strFolderB & strFile
strFile = Dir
Loop
End Sub
Greg
EDIT
Sub MoveFile()
Dim strFolderA As String
Dim strFile As String
Dim AccNo As String
strFolderA = "\\vs2-alpfc7\omgUSERS7\58129\G Test\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) > 0
AccNo = Left(strFile, 2)
Name strFolderA & strFile As strFolderA & "\" & AccNo & "\Data Extract\" & strFile
strFile = Dir
Loop
End Sub
Thanks folks, are a few more bits and pieces i want to add, but functionality is there!
Sub DivideFiles()
Const SourceDir = "C:\" 'where your files are
Const topdir = "\\vs2-alpfc\omgusers7\58129\G Test\"
Dim s As String
Dim x As String
s = Dir(SourceDir & "\*.xls?")
Do
x = Left(s, 3) 'I assume we're splitting by first three chars
Name SourceDir & s As topdir & s & "\" & s
Loop Until s = ""
End Sub
If I understand you correctly, the problem is deriving the new fullpathname from the file name to use as the newpathname argument of the Name function.
If all of your files end with DE.XLS* you can do something like:
NewPathName = C:\Data\ & Split(strFile, "DE")(0) & "\Data Extract\" & strFile
You could use Filesystem object (tools > references > microsoft scripting runtime
This does a copy first then delete. You can comment out delete line and check copy is safely performed.
If on Mac replace "\" with Application.PathSeparator.
Based on assumption, as you stated, that folders already exist.
Option Explicit
Sub FileAway()
Dim fileNames As Collection
Set fileNames = New Collection
With fileNames
.Add "123DE.xls"
.Add "124DE.xls"
.Add "125DE.xls"
.Add "124.doc"
.Add "123.csv"
End With
Dim fso As FileSystemObject 'tools > references > scripting runtime
Set fso = New FileSystemObject
Dim i As Long
Dim sourcePath As String
sourcePath = "C:\Users\User\Desktop" 'where files currently are
For i = 1 To fileNames.Count
If Not fso.FileExists("C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\" & fileNames(i)) Then
fso.CopyFile (sourcePath & "\" & fileNames(i)), _
"C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\", True
fso.DeleteFile (sourcePath & "\" & fileNames(i))
End If
Next i
End Sub
Dears I have this piece of code that checks if a file .xls in a target folder is already saved under format .xlsb in the ActiveWorkbook folder. this works properly for the first file but the loop stops after that and doesn't checks the remaining ones.
myFile = Dir(myPath & myExtension)
'check if the file .xls is in the current folder in format .xlsb
Do While myFile <> ""
If Dir(Application.ActiveWorkbook.Path & "\" & Replace(myFile, ".xls", ".xlsb")) <> "" Then
Debug.Print myFile & " is in the folder"
Else
Debug.Print myFile & " is not in the folder"
End If
'next file
myFile = Dir
Loop
You haven't created an array for looping the files from. Below is the code for checking file existance
Sub checkExistance()
'setup
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("Your Folder Path Here")
'file
Dim myFile As String
Dim FileName As String
Dim FileExtension As String
FileName = "Your File Name"
FileExtension = ".xls"
myFile = FileName & FileExtension
'Loop through each file in folder
For Each objFile In objFolder.Files
If objFile.Name = Replace(myFile, ".xls", ".xlsb") Then
MsgBox objFile.Name & " Ci sta"
Else
MsgBox objFile.Name & " Nun Ci sta"
End If
Next
End Sub
There is a function on another answer HERE that returns an array of files within a folder. If you grab that, you can get what you need with:
Dim myFile As Variant
Dim folder_containing_xls As String
Dim folder_containing_xlsb As String
folder_containing_xls = "FOLDER PATH HERE"
folder_containing_xlsb = Application.ActiveWorkbook.Path 'or "OTHER OR SAME FOLDER PATH HERE"
If Right(folder_containing_xls, 1) <> "\" Then folder_containing_xls = folder_containing_xls & "\"
If Right(folder_containing_xlsb, 1) <> "\" Then folder_containing_xlsb = folder_containing_xlsb & "\"
For Each myFile In listfiles(folder_containing_xls)
If myFile Like "*.xls" Then
If Dir(folder_containing_xlsb & Replace(myFile, ".xls", ".xlsb")) <> "" Then
Debug.Print myFile & " is in the folder"
Else
Debug.Print myFile & " is not in the folder"
End If
End If
Next
I couldn't work out if you were looking for both files to be in the same folder, or if they were in different folders, so I've built it to cope with either.
I am running a loop through a folder in order to get the complete filename address (folders address + file name and extension).
I am using the following, but at some point the Dir value is <Invalid procedure call or argument>
recsFolder = Functions.GetFolder("C:\")
recfile = recsFolder & "\" & Dir(recsFolder & "\*.rec*")
Do While Len(recfile) > 0
recfile = recsFolder & "\" & Dir
Loop
The error is thrown before the loop as completed reading all the files.
EDIT: another approach and Dir is changing everytime I press F8
If Right(recsFolder, 1) <> "\" Then recsFolder = recsFolder & "\"
numFiles = 0
recfile = Dir(recsFolder)
While recfile <> ""
numFiles = numFiles + 1
recfile = Dir()
Wend
I am trying this latest approach and I get the same error. The problem is that when I run the code line by line (F8) I can see that the Dir value changes everytime a new line of code is run inside the While.
Instead of DIR, how about this:
' enable Tools->References, Microsoft Scripting Runtime
Sub Test()
Dim fso As New Scripting.FileSystemObject
Dim fldr As Folder
Set fldr = fso.GetFolder("C:\test")
HandleFolder fldr
End Sub
Sub HandleFolder(fldr As Folder)
Dim f As File
Dim subFldr As Folder
' loop thru files in this folder
For Each f In fldr.Files
Debug.Print f.Path
Next
' loop thru subfolders
For Each subFldr In fldr.SubFolders
HandleFolder subFldr
Next
End Sub
IDK it it helps but this is a pretty solid frame
path = "yourpath" & "\"
Filename = Dir(path & "*.fileextension")
Do While Len(Filename) > 0
'some code
Filename = Dir
Loop
I currently have coded how to open all files in a certain folder
Dim MyFolder As String
Dim MyFile As String
MyFolder = "K:\Data Directories\Acquisitions"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open FileName:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
Now I'm trying to open all files in multiple folders that have the same name.
For instance:
Dim MyFolder As String
Dim MyFile As String
Dim MyFolder2 As String
MyFolder = "K:\Data Directories\Acquisitions"
MyFolder2 = MyFolder & "*\June 2015"
MyFile = Dir(MyFolder2 & "\*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open FileName:=MyFolder2 & "\" & MyFile
MyFile = Dir
Loop
The problem is the * that I place before June 2015. It comes out as an actual "*" in the path code instead of a wildcard.
The code is meant to choose all folders in the Acquisition directory, and then look inside them for a June 2015 folder. From there, all the Excel files in these multiple June 2015 folders should be opened. What am I doing wrong?
I think this will do what you want. Give it a try and see what happens.
Sub DoFolderPart1()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "K:\Data Directories\Acquisitions"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim strName As String
Dim pos As Integer
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
strName = Folder.name
pos = InStr(strName, "June 2015")
If pos > 0 Then
For Each File In Folder.Files
If Right(File, 4) = "xlsx" Then
Workbooks.Open Filename:=File
End If
Next
End If
End Sub
I based my answer on this loop-through-all-subfolders-using-vba
I am reading a list of files and come accross updated versions along the way. In my loop I am checking if the file already exists and trying to remove it, so that I can create the newer version again:
objFs = CreateObject("Scripting.FileSystemObject")
If (objFs.FileExists(location & "\" & fileName & ".xml")) Then
System.IO.File.Delete(location & "\" & fileName & ".xml")
End If
objTextStream = objFs.CreateTextFile(location & "\" & fileName & ".xml", True)
objTextStream.Write(System.Text.Encoding.UTF8.GetString(recordXml))
Ideally I would rather just open the file if it already exists and overwrite the contents, but so far my attempts have been in vein.
location is a user defined path, e.g. c://
recordXML is a retrieved value from the database
The main error I keep getting is
Additional information: Argument 'Prompt' cannot be converted to type 'String'.
Which seems to mean that the file is either not there to delete, or it is already there when I am trying to create it. The delete may not be working as it should, it may be that the file is not deleted in time to recreate it?..
That's my thoughts anyway.
Found this code at http://www.mrexcel.com/forum/excel-questions/325574-visual-basic-applications-check-if-folder-file-exists-create-them-if-not.html for creating a new file (unless one already exists) and then opening it (existing or new). Once you open, you can just do a Sheets(
NAMEOFSHEET").Cells.Clearto clear the cells and then paste your data.
Sub btncontinue_Click()
Dim myFile As String, myFolder As String
myFolder = "C:\TimeCards"
myFile = myFolder & "\timecards.xls"
If Not IsFolderExixts(myFolder) Then
CreateObject("Scripting.FileSystemObject").CreateFolder myFolder
End If
If Not IsFileExists(myFile) Then
MsgBox "No such file in the folder"
Exit Sub
End If
Set wb = Workbooks.Open(myFile)
' Your code here
End Sub
Function IsFolderExists(txt As String) As Boolean
IsFolderExists = _
Createobject("Scripting.FileSystemObject").FolderExists(txt)
End Function
Function IsFileExists(txt As String) As Boolean
IsFileExists = _
CreateObject("Scripting.FilesystemObject").FileExists(txt)
End Function
You could try this, it should work in VB, VBA and VBScript.
objFs = CreateObject("Scripting.FileSystemObject")
If objFs.FileExists(location & "\" & fileName & ".xml") Then Kill(location & "\" & fileName & ".xml")
Open location & "\" & fileName & ".xml" For Output As #1
Print #1, recordXml
Close #1
Try to use FSO to delete the file. Also the objTextStream needs to be set because it is object.
Sub AnySub()
Dim objFs As FileSystemObject
Set objFs = CreateObject("Scripting.FileSystemObject")
If (objFs.FileExists(Location & "\" & Filename & ".xml")) Then
objFs.DeleteFile Location & "\" & Filename & ".xml"
End If
Set objTextStream = objFs.CreateTextFile(Location & "\" & Filename & ".xml", True)
objTextStream.Write recordXml
End Sub
I m not sure the .write method work with UTF8.
I m using this function:
Sub File_WriteToUTF8(File_Path As String, s_Content As String)
On Error GoTo ende
Dim LineStream As Object
Set LineStream = CreateObject("ADODB.Stream")
With LineStream
.Type = 2
.Mode = 3
.Charset = "utf-8"
.Open
.WriteTEXT s_Content
.SaveToFile File_Path, 2
ende:
.Close
End With
End Sub
So instead of
objTextStream.Write recordXml
it would be
File_WriteToUTF8 Location & "\" & Filename & ".xml", recordXml