I want to get the last modified date of a ppt file and put the condition : if it's in after thursady of the week than out else go on. That's what i wrote but it doesn't work!
Sub proprietes()
Set fs = CreateObject("Scripting.FileSystemObject")
FilePath = "C:\Users\Moez\Desktop\Macro Project\test v2"
Set f = fs.GetFile(FilePath)
fileModDate = f.DateLastModified
End Sub
i always get the mistake in Set f = fs.GetFile(FilePath)!!
Could you help me please?
thanks a lot
Try this
Sub proprietes()
Set fs = CreateObject("Scripting.FileSystemObject")
FilePath = "C:\Users\....\Desktop\TestPPT.pptx"
Set f = fs.GetFile(FilePath)
fileModDate = f.DateLastModified
End Sub
maybe something like this
FilePath = Dir("C:\Users\Moez\Desktop\Macro Project\test v2*")
fileModDate = FileDateTime(FilePath)
https://www.techonthenet.com/excel/formulas/filedatetime.php
Related
I have got this far but when I set the value for 'Folder' it is empty and the 'FolderPath' is "F:\Video Clips" what am I doing wrong
Function GetFileLength(FolderPath As String, FileName As String) As Date
'
' Get the run time of a audio/video file
'
' Set Up
Dim Shell As Object
Dim Folder As Object
Dim File As Object
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(FolderPath)
'Set Folder = Shell.Namespace("F:\Video Clips")
Set File = Folder.ParseName(FileName)
' Get time
If LCase(Right(FileName, 3)) = "avi" Then
GetFileLength = Folder.GetDetailsOf(File, 27)
Else
GetFileLength = ""
End If
End Function
Try it with the data type variant for the folder path in your function. Also have a look at the documentation of Namespace.
Function GetFileLength(FolderPath As Variant, FileName As String) As Date
'
' Get the run time of a audio/video file
'
' Set Up
Dim Shell As Object
Dim Folder As Object
Dim File As Object
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(FolderPath)
'Set Folder = Shell.Namespace("F:\Video Clips")
Set File = Folder.ParseName(FileName)
' Get time
If LCase(Right(FileName, 3)) = "avi" Then
GetFileLength = Folder.GetDetailsOf(File, 27)
Else
GetFileLength = ""
End If
End Function
PS Another bug you have is that the else condition GetFileLength = "" will fail because a string is not a date. Maybe you should use GetFileLength = CDate(0) or whatever you think is appropriate.
Everyone!
I'm working on macros which should select cdrBitmapShape and save it as a separate file.
I've already found out how to search and select such an object, but I've run into a problem of saving it.
I don't get how should I save the chosen image, it is quite unclear from the docs.
As I understand from here I should somehow assign to the Document variable the current selection Item and export it.
Here is the test file
How can I do that?
Sub Findall_bit_map()
' Recorded 03.02.2020
'frmFileConverter.Start
'Dim d As Document
Dim retval As Long
Dim opt As New StructExportOptions
opt.AntiAliasingType = cdrNormalAntiAliasing
opt.ImageType = cdrRGBColorImage
opt.ResolutionX = 600
opt.ResolutionY = 600
Dim pal As New StructPaletteOptions
pal.PaletteType = cdrPaletteOptimized
pal.NumColors = 16
pal.DitherType = cdrDitherNone
Dim Filter As ExportFilter
Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
For Each shpCheck In OrigSelection
re = shpCheck.Type
If shpCheck.Type = cdrBitmapShape Then
retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
shpCheck.AddToSelection
Set Filter = Document.ExportBitmap("D:\some.jpg", cdrJPEG)
If Filter.ShowDialog() Then
Filter.Finish
Else
MsgBox "Export canceled"
End If
End If
Next shpCheck
retval = MsgBox("Click OK if you agree.", vbOKCancel, "Easy Message")
'ActivePage.Shapes.FindShapes(Query:="#type='BitmapShape'")
If retval = vbOK Then
MsgBox "You clicked OK.", vbOK, "Affirmative"
End If
End Sub
I don't know were was the bug, but here is the working version.
Sub Findall_bit_map_snip()
Dim retval As Long
Dim doc As Document
Dim pal As New StructPaletteOptions
pal.PaletteType = cdrPaletteOptimized
pal.ColorSensitive = True
pal.NumColors = 300000000
pal.DitherType = cdrDitherNone
Dim Filter As ExportFilter
Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
For Each shpCheck In OrigSelection
Set doc = ActiveDocument
doc.ClearSelection
re = shpCheck.Type
If shpCheck.Type = cdrBitmapShape Then
retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
shpCheck.AddToSelection
Set Filter = doc.ExportBitmap("D:\some.jpg", cdrJPEG, cdrSelection, , , , 600, 600, cdrNoAntiAliasing, , False, , , , pal)
Filter.Finish
End If
Next shpCheck
End Sub
I have the below code which does everything except insert the page break after row 35. can anyone help please?
Sub PrintSet()
Dim rs As Worksheet
Dim sPrintArea As String
sPrintArea = "A1:AE65"
For Each rs In Sheets
rs.PageSetup.Orientation = xlLandscape
rs.PageSetup.Zoom = False
rs.PageSetup.FitToPagesWide = 1
rs.PageSetup.FitToPagesTall = 2
rs.PageSetup.PrintArea = sPrintArea
rs.HPageBreaks.Add before:=Range("A36")
Next rs
End Sub
Rewrite the last line like this:
rs.HPageBreaks.Add before:=rs.Range("A36")
Thus, you are adding a reference rs also. It should work better. See what Microsoft says about referencing ranges:
https://msdn.microsoft.com/en-us/library/office/aa221547(v=office.11).aspx
Try something like this:
Dim hpgbr As HPageBreak
Dim hpgbrs As HPageBreaks
Set hpgbr = hpgbrs.Add(Before:=Range("A36"))
This works for me. I removed the Zoom
Sub PrintSet()
Dim rs As Worksheet
Dim sPrintArea As String
sPrintArea = "A1:AE65"
For Each rs In Sheets
rs.PageSetup.Orientation = xlLandscape
rs.PageSetup.FitToPagesWide = 1
rs.PageSetup.FitToPagesTall = 2
rs.PageSetup.PrintArea = sPrintArea
rs.HPageBreaks.Add before:=Range("A36")
Next rs
End Sub
As the title suggests, I have three separate text files that I want to join together in a certain order (i.e., append file1, file2, file3 (in order) to make file4).
From what I've read, to do this with VBScript would require the FileSystemObject to read the files into an array then write the contents to the new file (I am open to whatever works with VBScript if suggested)
I'm having the following issues with my code:
1) The script runs, but produces no data
2) After I get it to run, it is imperative that the files append to the output file in the order of the array in the order (per line) I suggest above.
Here is the Array example I'm working with :
CODE
Const ForReading = 1
Dim arrServiceList(2)
arrServiceList(0) = strText1
arrServiceList(1) = strText2
arrServiceList(2) = strText3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("output.txt")
Set objTextFile1 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample1.txt", ForReading)
Set objTextFile2 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample2.txt", ForReading)
Set objTextFile3 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample3.txt", ForReading)
strText1 = objTextFile1.ReadAll
objTextFile1.Close
strText2 = objTextFile2.ReadAll
objTextFile2.Close
strText3 = objTextFile3.ReadAll
objTextFile3.Close
objOutputFile.WriteLine arrServiceList(0)
objOutputFile.Close
====================
UPDATE TO MY CODE 5-15-15 (Description of corrections in below post)
CODE
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("output.txt")
Set objTextFile1 = objFSO.OpenTextFile("C:\Users\Brill\Desktop\Grab1.txt", ForReading)
Set objTextFile2 = objFSO.OpenTextFile("C:\Users\Brill\Desktop\Grab2.txt", ForReading)
Set objTextFile3 = objFSO.OpenTextFile("C:\Users\Brill\Desktop\Grab3.txt", ForReading)
Do While objTextFile1.AtEndOfStream <> True
Do While objTextFile2.AtEndOfStream <> True
Do While objTextFile3.AtEndOfStream <> True
strText1 = objTextFile1.ReadLine
objOutputFile.Write strText1 & vbTab
strText2 = objTextFile2.ReadLine
objOutputFile.Write strText2 & vbTab
strText3 = objTextFile3.ReadLine
objOutputFile.Write strText3 & vbTab & vbCrLf
Loop
Loop
Loop
objOutputFile.Close
objTextFile1.Close
objTextFile2.Close
objTextFile3.Close
The below works.
Problems with your script. 1. You were assigning the variables to the array before you had populated them. 2. You were not writing all the elements of the array.
Const ForReading = 1
Dim arrServiceList(2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("output.txt")
Set objTextFile1 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample1.txt", ForReading)
Set objTextFile2 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample2.txt", ForReading)
Set objTextFile3 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample3.txt", ForReading)
strText1 = objTextFile1.ReadAll
objTextFile1.Close
strText2 = objTextFile2.ReadAll
objTextFile2.Close
strText3 = objTextFile3.ReadAll
objTextFile3.Close
arrServiceList(0) = strText1
arrServiceList(1) = strText2
arrServiceList(2) = strText3
objOutputFile.WriteLine arrServiceList(0)
objOutputFile.WriteLine arrServiceList(1)
objOutputFile.WriteLine arrServiceList(2)
objOutputFile.Close
Merging/Zipping more then one collection (e.g. some 'column files') into one collection (e.g. a 'table file') is a standard problem with a standard solution strategy (which doesn't involve reading "the files into an array" at all).
This demo code:
Option Explicit
Dim goFS : Set goFS = CreateObject("FileSystemObject")
Dim oFZip : Set oFZip = New cFZip
oFZip.m_aIFSpecs = Split("..\data\a.txt ..\data\b.txt ..\data\c.txt")
oFZip.zip "..\data\abc.txt"
WScript.Echo goFS.OpenTextFile("..\data\abc.txt").ReadAll()
Class cFZip
Public m_aIFSpecs ' array of input files
Function zip(sOFSpec)
Dim tsOut : Set tsOut = goFS.CreateTextFile(sOFSpec)
Dim nUBFiles : nUBFiles = UBound(m_aIFSpecs)
ReDim aFiles(nUBFiles)
Dim f
For f = 0 To nUBFiles
Set aFiles(f) = goFS.OpenTextFile(m_aIFSpecs(f))
Next
Dim bDone
Do
Redim aData(UBound(m_aIFSpecs))
bDone = True
For f = 0 To nUBFiles
If Not aFiles(f).AtEndOfStream Then
bDone = False
aData(f) = aFiles(f).ReadLine()
End If
Next
If Not bDone Then tsOut.WriteLine Join(aData, ",")
Loop Until bDone
For f = 0 To nUBFiles
aFiles(f).Close
Next
tsOut.Close
End Function
End Class
output:
1,10,100
2,20,200
3,30,300
4,,400
,,500
shows the basic approach. I use a Class to make experiments/specific adaptions (e.g. delimiter, quoting, ...) easier.
I have a file with following content
aaaaaaaaa filename1.txt
bbbbbbbbbb filename2.dat
i want to read this file and store data to the relevent file seperately.
eg :- aaaaa ---> filename1.txt
Could someone please tell me the way to do this? If you have any worked through examples, that would be a real help!
Sub Main
Set ctlpath = "\\Download_Directory\CA.ctl"
Set subDirectory = "AUB"
Set MkrExtention = ".mkr"
ReadCtl(ctlpath,subDirectory,MkrExtention )
End Sub
Function ReadCtl(ctlFileName,ctlSubDirectory,MarkerFileExtension)
Const ForReading = 1
Const ForWriting = 2
Dim lineData,hashValue,fileName,fileToWrite
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(ctlFileName) Then
Set objFile = objFSO.OpenTextFile(ctlFileName, ForReading)
Do Until objFile.AtEndOfStream
lineData = objFile.ReadLine
hashValue =Split(lineData," ") (0)
fileName =Split(lineData," ") (1)
WriteFileText("\\Download"+ctlSubDirectory+"
\"+fileName+MarkerFileExtension,hashValue)
Loop
objFile.Close
objFSO.Close
End If
ReadCtl = True
End Function
Function WriteFileText(sFilePath, sText)
Dim objFSO1 'As FileSystemObject
Dim objTextFile 'As Object
Set objFSO1 = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO1.CreateTextFile(sFilePath, True)
' Write hash data in to the file .mkr file
objTextFile.Write (sText)
objTextFile.Close
objFSO1.Close
End Function
A long time since you asked this, surprises me nobody answered, is simple enough.
Hope you'r still around, anyway here for reference. This is no real hash like eg in Ruby of course but i kept enough of your script so that you can compare.
ReadCtl("file2hash1.txt")
function ReadCtl(ctlFileName)
const ForReading = 1, ForWriting = 2, ForAppending = 8, createIfNeeded = true
set oFso = createObject("Scripting.FileSystemObject")
Set oRegExpre = new RegExp
oRegExpre.Global = true
oRegExpre.Pattern = "(.*) +(.*)"
if oFso.FileExists(ctlFileName) then
set objFileRead = oFso.OpenTextFile(ctlFileName, ForReading)
do until objFileRead.AtEndOfStream
lineData = objFileRead.ReadLine
hashValue = oRegExpre.Replace(lineData,"$1")
fileName = oRegExpre.Replace(lineData,"$2")
if oFso.fileExists(fileName) then
modus = ForAppending
else
modus = ForWriting
end if
set objFileWrite = oFso.OpenTextFile(fileName, modus, createIfNeeded)
objFileWrite.writeLine hashValue
objFileWrite.close
loop
objFileRead.close
end if
set oFso = nothing
end function