I am working on a backup script in VBS that creates a folder and then copies a powerpoint file into the most recently created folder.
Everything works great except MoveFile command at the bottom
Here is what I got so far (the bottom code is most important but just so everyone can understand where I am coming from):
sourceDir = "T:\Team"
destinationDir = "T:\Team\Archive\Archive"
const OverwriteExisting = True
intNum = 1
strDirectory = destinationDir & "_" & replace(date,"/",".") & "_" & intNum
'This checks if the folder exists and if not it will create a folder with the date and increment the folder name incase there are multiple updates in a single day.
if not filesys.FolderExists(destinationDir) then
While filesys.FolderExists(destinationDir & "_" & replace(date,"/",".") & "_" & intNum) = True
intNum = intNum + 1
Wend
Set archivefolder = filesys.CreateFolder(destinationDir & "_" & replace(date,"/",".") & "_" & intNum)
Else
Set archivefolder = filesys.CreateFolder(destinationDir)
Set objFolder = fso.CreateFolder(strDirectory)
End if
Dim thisday, thisdayy, thisdayyy
Today_Date()
' This is the problem code
filesys.MoveFile "T:\Arriva\Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm", "destinationDir & "\" & Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm"
Function Today_Date()
thisday=Right(Day(Date),2)
thisdayy=Right("0" & Month(Date),2)
thisdayyy=Right("0" & Year(Date),2)
End Function
This results in a folder being created as "T:\Team\Archive\Archive_03.12.2014_1
My goal is to be able to move the file in T:\Team to the dynamically created folder above.
Everything works great until the MoveFile part. The destination is the part throwing a "type mismatch" at the line where I define the strDirectory
I am just learning this type of programming so please let me know if I can provide any further details!
Thank you in advance!
You have a couple syntax errors with your quotes that are cancelling each other out. Change your line to this:
filesys.MoveFile "T:\Team\Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm", "destinationDir" & "_" & replace(date,"/",".") & "_" & intNum & "\" & "Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm"
Related
I am able to create a new directory on my desktop, my issues is that I don't know how to save multiple files into that folder, within the same Sub, since it has a dynamic name.
Option Explicit
Sub Make_Folder_On_Desktop()
Dim selectionsheet As Worksheet
Dim Group As Variant
Dim amount As Long
Dim BU As Long
Dim BUname As Variant
Dim sFilename As Variant
Set selectionsheet = Sheets("Project Selection")
Group = selectionsheet.Range("A19").Value
amount = selectionsheet.Range("B19").Value
BU = selectionsheet.Range("B6").Value
BUname = selectionsheet.Range("C6").Value
sFilename = BU & " - " & BUname
MkDir Group & " - " & amount & " - " & Format(Date, "mm-dd-yyyy") & " - "
& Format(Time, "hhmmss")
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sFilename
End Sub
Last line is where I'm having the issue. I have "ThisWorkbook.Path" but can't figure out how to get it into the new folder I just created.
MkDir Group & " - " & amount & " - " & Format(Date, "mm-dd-yyyy") & " - " & Format(Time, "hhmmss")
It's hard to know what the folder name is that you just created, because that instruction is responsible for too many things. Split it up.
Build/concatenate a folder name
Make a directory by that name
If we split up the work, things get much simpler:
Dim path As String
path = Group & " - " & amount & " - " & Format(Date, "mm-dd-yyyy") & " - " & Format(Time, "hhmmss")
MkDir path
And now we have the path in the ...path variable, readily usable for anything you might want to do with it:
ActiveWorkbook.SaveAs path & "\" & sFilename
As a side note, if you make the date format yyyy-mm-dd instead, you're ISO-compliant (i.e. the date is unambiguous everywhere in the world), and the folders become sortable by name.
Note that the procedure's name is misleading: it doesn't care where the folder is, and there's nothing that says it's under %USERPROFILE%\Desktop. Use Environ$("USERPROFILE") to retrieve the base path for the current user's profile directory.
I am using MS Access Forms and I am trying to open a file but don't know how to open the file based knowing only part of the name. Example below works
Private Sub Open_Email_Click()
On Error GoTo Err_cmdExplore_Click
Dim x As Long
Dim strFileName As String
strFileName = "C:\data\office\policy num\20180926 S Sales 112.32.msg"
strApp = """C:\Program Files\Microsoft Office\Office15\Outlook.exe"""
If InStr(strFileName, " ") > 0 Then strFileName = """" & strFileName & """"
x = Shell(strApp & " /f " & strFileName)
Exit_cmdExplore_Click:
Exit Sub
Err_cmdExplore_Click:
MsgBox Err.Description
Resume Exit_cmdExplore_Click
End Sub
If I change the strFilename to being
strFileName = "C:\data\" & Me.Office & "\" & Me.nm & " " & Me.pol & "\" & "*"& " S Sales " & Me.amt & "*" & ".msg"
It includes the * rather than using it as a wildcard, the date/numbers can be anything or in another format but always eight numbers. I tried using a while loop on the numbers but I am not sure the best way of doing this sorry.
You can use the Dir function to iterate over all files that match a string pattern.
strApp = """C:\Program Files\Microsoft Office\Office15\Outlook.exe"""
Dim strFilePattern As String
strFilePattern ="C:\data\" & Me.Office & "\" & Me.nm & " " & Me.pol & "\" & "*"& " S Sales " & Me.amt & "*" & ".msg"
Dim strFileName As String
strFileName = Dir(strFilePattern)
Do While Not strFileName = vbNullString
If InStr(strFileName, " ") > 0 Then strFileName = """" & strFileName & """"
x = Shell(strApp & " /f " & strFileName)
strFileName = Dir
Loop
The first call to Dir with the pattern as a parameter will find the first file that matches the pattern supplied. All subsequent calls without the pattern will return the next file that matches the pattern.
So, lets rebuild the question a bit. Imagine that you are having the following 5 files in a given folder:
A:\peter.msg
A:\bstack.msg
A:\coverflow.msg
A:\heter.msg
A:\beter.msg
and you need to find the files, that correspond to "A:\*eter.msg" and print them.
For this, you need to use the keyword Like:
Sub TestMe()
Dim someNames As Variant
someNames = Array("A:\peter.msg", "A:\bstack.msg", _
"A:\coverflow.msg", "A:\heter.msg", "A:\beter.msg")
Dim cnt As Long
For cnt = LBound(someNames) To UBound(someNames)
If someNames(cnt) Like "A:\*eter.msg" Then
Debug.Print someNames(cnt)
End If
Next
End Sub
Loop through files in a folder using VBA?
I have a 3D model of an intricate chimney which is essentially a cylindrical tube with decorative features. I'd like to write a VBA script which find the section properties at several points along its length but I'm not really sure how to do it.
From online searches, I've managed to write a code which puts in a section at a point which I can then run MASSPROP on but I'm not quite sure how to finish it off... I think I'm only one line of code away. I just need to select the section that I've just created.
My almost complete code is below with a comment on the line that I need help with.
Public Sub Section()
Dim SolidObject As Acad3DSolid
Dim NewRegionObject As AcadRegion
Dim PlaneOrigin As Variant
Dim PlaneXaxisPoint As Variant
Dim PlaneYaxisPoint As Variant
Dim PickedPoint As Variant
On Error Resume Next
With ThisDrawing.Utility
.GetEntity SolidObject, PickedPoint, vbCr & "Select solid to cut."
If Err Then
MsgBox "Selected solid must be a 3DSolid"
Exit Sub
End If
PlaneOrigin = .GetPoint(PickedPoint, vbCr & "Select point to define origin.")
PlaneXaxisPoint = .GetPoint(PickedPoint, vbCr & "Select point to define x-axis.")
PlaneYaxisPoint = .GetPoint(PickedPoint, vbCr & "Select point to define y-axis.")
Set NewRegionObject = SolidObject.SectionSolid(PlaneOrigin, PlaneXaxisPoint, PlaneYaxisPoint)
End With
ThisDrawing.SendCommand ("qaflags" & vbCr & "2" & vbCr) 'This is needed for the operation
ThisDrawing.SendCommand ("massprop" & vbCr)
'How do I select my NewRegionObject???
ThisDrawing.SendCommand (vbCr & vbCr & "y" & vbCr & vbCr & "y" & vbCr)
End Sub
If I can get this code to run MASSPROP with my newly created section fine I should be able to adapt it to do the process automatically at several points along the chimney so I think I'm only one line of code off.
Thanks for your help,
Tom
you'd better exploit Autocad Object Model:
Dim minPoint As Variant, maxPoint As Variant
Set NewRegionObject = SolidObject.SectionSolid(PlaneOrigin, PlaneXaxisPoint, PlaneYaxisPoint)
With NewRegionObject
MsgBox "Area: " & .Area
MsgBox "Perimeter: " & .Perimeter
.GetBoundingBox minPoint, maxPoint
MsgBox "Min Point coordinates: (" & minPoint(0) & "," & minPoint(1) & "," & minPoint(2) & ")"
MsgBox "Max Point coordinates: (" & maxPoint(0) & "," & maxPoint(1) & "," & maxPoint(2) & ")"
MsgBox "Centroid coordinates: (" & .Centroid(0) & "," & .Centroid(1) & ")"
MsgBox "Moments of Inertia: (" & .MomentOfInertia(0) & "," & .MomentOfInertia(1) & "," & .MomentOfInertia(2) & ")"
'.. and so on
End With
'' I created a folder like this and it contains many databases. When I'm about to submit again the button there was an error of "Database already exist" i am saying that I'm about to delete the src folder instead of the databases. What should I do then? What code to use?
Dim testPath1 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Compare"
Dim testPath5 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Entry1"
Dim testPath2 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Entry2"
Dim testPath3 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Images"
Dim testPath4 As String = Form1.Dir_folder.Text & "\CBATCH"
Dim testPath6 As String = Form1.Dir_folder.Text & "\CBATCH" & "\CardDeck" & "\" & DateTime.Now.ToString("yyyyMMdd")
If Not IO.Directory.Exists(testPath5) Then
MkDir(testPath5)
End If
If Not IO.Directory.Exists(testPath1) Then
MkDir(testPath1)
End If
If Not IO.Directory.Exists(testPath2) Then
MkDir(testPath2)
End If
If Not IO.Directory.Exists(testPath3) Then
MkDir(testPath3)
End If
If Not IO.Directory.Exists(testPath4) Then
MkDir(testPath4)
End If
If Not IO.Directory.Exists(testPath6) Then
MkDir(testPath6)
End If
To be honest MkDir isnt the quickest way to create directories, but for consistency, just use
RmDir(testPath1)
A better performing way would be to use..
My.Computer.FileSystem.CreateDirectory(testPath1)
to create a directory and ..
My.Computer.FileSystem.DeleteDirectory(testPath1,FileIO.DeleteDirectoryOption.DeleteAllContents)
to delete it/
You can't. My answer had nothing to do with using databases. Which is why I apologised for misreading your original question. I should delete it and let someone else answer.
I'm trying to move my entire User folder in Vista to a non-system partition. To do so with a minimum hassle I'm following the directions provided at Ben's Blog, specifically the vbs script he provides. However executing the script throws up an error which I can't resolve myself. Here's the vbs code followed by the text file it calls on, and finally my error message. Can someone help me correct the problem? (I really don't know much about VBS, so please write as simple as possible.)
VBS Code:
'# Perform dir /a c:\users > c:\dir.txt
'# place this script file in c:\ too
'# double click to run it
'# run resulting script.bat from recovery mode
repprefix = " Directory of..." ' Modify to your language
sourcedrive = "C:\"
targetdrive = "D:\"
altsourcedrive = "C:\" 'leave same as target drive unless otherwise indicated
alttargetdrive = "E:\" 'leave same as target drive unless otherwise indicated
inname = "dir.txt"
outname = "script.bat"
userroot = "Users"
set fso = CreateObject("Scripting.FileSystemObject")
' construct batch commands for saving rights, then link, the recreating rights
Function GetCommand(curroot, line, typ, keyword)
' first need to get source and target
pos = Instr(line, keyword) + Len(keyword)
tuple = Trim(Mid(line, pos))
arr = Split(tuple, "[")
oldtarget = Replace(arr(1), "]", "")
oldlink = curroot & "\" & Trim(arr(0))
' need to determine if we are pointing back to old disk
newlink = replace(oldlink, sourcedrive, targetdrive)
if(Instr(oldtarget, sourcedrive & userroot)) then
newtarget = Replace(oldtarget, sourcedrive, targetdrive)
else
newtarget = oldtarget ' still pointing to original target
end if
' comment
out = "echo " & newlink & " --- " & newtarget & vbCrLf
' save permissions
out = out & "icacls """ & replace(oldlink, sourcedrive, altsourcedrive) & """ /L /save " & altsourcedrive & "permissions.txt" & vbCrLf
' create link
newlink = replace(newlink, targetdrive, alttargetdrive)
if typ = "junction" then
out = out & "mklink /j """ & newlink & """ """ & newtarget & """" & vbCrLf
else ' typ = "symlink"
out = out & "mklink /d """ & newlink & """ """ & newtarget & """" & vbCrLf
end if
'set hidden attribute
out = out & "attrib +h """ & newlink & """ /L" & vbCrLf
' apply permissions
shortlink = Left(newlink, InstrRev(newlink, "\") - 1) 'icacls works strangely - non-orthogonal for restore
out = out & "icacls """ & shortlink & """ /L /restore " & altsourcedrive & "permissions.txt" & vbCrLf
GetCommand = out & vbCrLf
End Function
Sub WriteToFile(file, text)
ForWriting = 2
Create = true
set outfile = fso.OpenTextFile(file, ForWriting, Create)
Call outfile.Write(text)
Call outfile.Close()
End Sub
outtext = "ROBOCOPY " & altsourcedrive & userroot & " " & alttargetdrive & userroot & " /E /COPYALL /XJ" & vbCrLf & vbCrLf
set intext = fso.OpenTextFile(inname)
while not intext.AtEndOfStream
line = intext.ReadLine()
if Instr(line, repprefix) then
curroot = Replace(line, repprefix, "")
elseif Instr(line, juncname) then
outtext = outtext & GetCommand(curroot, line, "junction", juncname)
elseif Instr(line, linkname) then
outtext = outtext & GetCommand(curroot, line, "symlink", linkname)
end if
Wend
outtext = outtext & "icacls " & altsourcedrive & userroot & " /L /save " & altsourcedrive & "permissions.txt" & vbCrLf
outtext = outtext & "ren " & altsourcedrive & userroot & " _" & userroot & vbCrLf
outtext = outtext & "mklink /j " & altsourcedrive & userroot & " " & targetdrive & userroot & vbCrLf
outtext = outtext & "icacls " & altsourcedrive & " /L /restore " & altsourcedrive & "permissions.txt"
Call intext.Close()
Call WriteToFile(outname, outtext)
MsgBox("Done writing to " & outname)
dir.txt:
Volume in drive C is ACER
Volume Serial Number is 08D7-C0CC
Directory of c:\users
07/16/2009 12:29 PM <DIR
07/16/2009 12:29 PM <DIR> ..
11/02/2006 09:02 AM <SYMLINKD> All Users [C:\ProgramData]
11/02/2006 09:02 AM <DIR> Default
11/02/2006 09:02 AM <JUNCTION> Default User [C:\Users\Default]
08/21/2008 08:37 AM 174 desktop.ini
11/02/2006 08:50 AM <DIR> Public
07/19/2009 08:54 PM <DIR> Steve
1 File(s) 174 bytes
7 Dir(s) 5,679,947,776 bytes free
Error Message:
Windows Script Host
Script: C:\userlocationchange.vbs
Line: 25
Char: 2
Error: Subscript out of range: '[number: 1]'
Code: 800A0009
Source: Microsoft VBScript runtime error
The problem is at these lines:
arr = Split(tuple, "[")
oldtarget = Replace(arr(1), "]", "")
I assume that arr(1) is giving the error because arr has only one entry - and since arrays are zero-based in VBS, that entry should be accessed as arr(0).
Hmmm... if there's only one entry, then presumably no "[" was found. The code probably needs to check for that (by testing whether UBound(arr) > 1).
What that means in a wider context - i.e. why there's no "[" I can't say.
EDIT: OK, I took a look at the blog you referred to, and the exact same problem was reported. The blog author replied:
A couple of pointers: look in the txt
file output by the dir command. On my
system, the targets of the symlinks
are shown in square brackets [].
Apparently in your case there aren't
any - in any case that is a hypothesis
that would explain why the script
can't parse out the link targets.
...which pretty much confirms my theory. I suggest you do as he suggests and take a look at the txt file to see if some other character is used.
Note that this isn't really a problem with the script per se - it's just that the script expects some input that it's not getting.
#Gary, I'm the same one who reported the problem on that blog.
I posted the txt file here under the VBS code. My txt file also has the symlink-junction targets within square brackets. Is there anything else I'm missing?