If I have the full path of a file:
eg. c:\files\file.txt
What would be the easiest way to get the folder of this file: eg. c:\files\ ?
Use FileSystemObject.GetParentFolderName(strFullFilePath) e.g.
Dim strFullFilePath As String
strFullFilePath = "c:\files\file.txt"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
MsgBox fso.GetParentFolderName(strFullFilePath)
Note this returns c:\file rather than c:\file\
You can use InStrRev for searching for the \, and Left$ for extracting the path bit:
filename = "c:\files\file.txt"
posn = InStrRev(filename, "\")
If posn > 0 Then
pathstr = Left$(filename, posn)
Else
pathstr = ""
End If
I'd make a function out of it for ease of use:
Function pathOfFile(fileName As String) As String
Dim posn As Integer
posn = InStrRev(fileName, "\")
If posn > 0 Then
pathOfFile = Left$(filename, posn)
Else
pathOfFile = ""
End If
End Function
' GetFilenameWithoutExtension: Return filename without extension from complete path
Public Function GetFilenameWithoutExtension(path As String) As String
Dim pos As Integer
Dim filename As String
pos = InStrRev(path, "\")
If pos > 0 Then
filename = Mid$(path, pos + 1, Len(path))
GetFilenameWithoutExtension = Left(filename, Len(filename) - Len(Mid$(filename, InStrRev(filename, "."), Len(filename))))
Else
GetFilenameWithoutExtension = ""
End If
End Function
' GetFilenameWithExtension: Return filename with extension from complete path
Public Function GetFilenameWithExtension(path As String) As String
Dim pos As Integer
pos = InStrRev(path, "\")
If pos > 0 Then
GetFilenameWithExtension = Mid$(path, pos + 1, Len(path))
Else
GetFilenameWithExtension = ""
End If
End Function
' GetDirectoryFromPathFilename: Return directory path contain filename
Public Function GetDirectoryFromPathFilename(path As String) As String
Dim pos As Integer
pos = InStrRev(path, "\")
If pos > 0 Then
GetDirectoryFromPathFilename = Left$(path, pos)
Else
GetDirectoryFromPathFilename = ""
End If
End Function
Related
How can I pass the data generated by the EliminaAcentos function to the
URLEncode function in this script?
The first function removes diacritics and the second function URL-encodes the data.
Function EliminaAcentos(texto)
Dim i, s1, s2
s1 = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜàáâãäåçèéêëìíîïòóôõöùúûü"
s2 = "AAAAAACEEEEIIIIOOOOOUUUUaaaaaaceeeeiiiiooooouuuu"
If Len(texto) <> 0 Then
For i = 1 To Len(s1)
texto = Replace(texto, Mid(s1,i,1), Mid(s2,i,1))
Next
End If
EliminaAcentos = texto
End Function
Function URLEncode(ByVal str)
Dim strTemp, strChar
Dim intPos, intASCII
strTemp = ""
strChar = ""
For intPos = 1 To Len(str)
intASCII = Asc(Mid(str, intPos, 1))
If intASCII = 32 Then
strTemp = strTemp & "+"
ElseIf ((intASCII < 123) And (intASCII > 96)) Then
strTemp = strTemp & Chr(intASCII)
ElseIf ((intASCII < 91) And (intASCII > 64)) Then
strTemp = strTemp & Chr(intASCII)
ElseIf ((intASCII < 58) And (intASCII > 47)) Then
strTemp = strTemp & Chr(intASCII)
Else
strChar = Trim(Hex(intASCII))
If intASCII < 16 Then
strTemp = strTemp & "%0" & strChar
Else
strTemp = strTemp & "%" & strChar
End If
End If
Next
URLEncode = strTemp
End Function
WScript.Echo URLEncode(WScript.Arguments(0))
Basically there are two ways to go about it:
You can nest the call of EliminaAcentos in the call of URLEncode as #JosefZ suggested:
URLEncode(EliminaAcentos(WScript.Arguments(0)))
You can embed the call of EleminaAcentos in the body of the URLEncode function:
Function URLEncode(ByVal str)
Dim strTemp, strChar
Dim intPos, intASCII
strTemp = ""
strChar = ""
str = EliminaAcentos(str)
For intPos = 1 To Len(str)
...
Next
URLEncode = strTemp
End Function
Usually you'd pick the first option if there are situations where you call URLEncode and don't want diacritics removed, or if you don't control the implementation of URLEncode. If you always want URLEncode to remove diacritics and you control the function implementation you'd pick the second option.
Side note (also mentioned by #JosefZ): pass the parameter to EliminaAcentos by value, so the function call doesn't inadvertently modify the original value.
Function EliminaAcentos(ByVal texto)
...
End Function
i m using asp classic. i want to rename image file while i upload image on web folder created by me. please help me out of this issue.
If there is a file in targeted folder with same name (like lokesh.jpg) what i am uploading, than new file should b automatically renamed(like lokesh(1).jpg) instead of overwriting
my code is as below:
upload.asp
<%
Class FileUploader
Public Files
Private mcolFormElem
Private Sub Class_Initialize()
Set Files = Server.CreateObject("Scripting.Dictionary")
Set mcolFormElem = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
If IsObject(Files) Then
Files.RemoveAll()
Set Files = Nothing
End If
If IsObject(mcolFormElem) Then
mcolFormElem.RemoveAll()
Set mcolFormElem = Nothing
End If
End Sub
Public Property Get Form(sIndex)
Form = ""
If mcolFormElem.Exists(LCase(sIndex)) Then Form = mcolFormElem.Item(LCase(sIndex))
End Property
Public Default Sub Upload()
Dim biData, sInputName
Dim nPosBegin, nPosEnd, nPos, vDataBounds, nDataBoundPos
Dim nPosFile, nPosBound
biData = Request.BinaryRead(Request.TotalBytes)
nPosBegin = 1
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
If (nPosEnd-nPosBegin) <= 0 Then Exit Sub
vDataBounds = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
nDataBoundPos = InstrB(1, biData, vDataBounds)
Do Until nDataBoundPos = InstrB(biData, vDataBounds & CByteString("--"))
nPos = InstrB(nDataBoundPos, biData, CByteString("Content-Disposition"))
nPos = InstrB(nPos, biData, CByteString("name="))
nPosBegin = nPos + 6
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sInputName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosFile = InstrB(nDataBoundPos, biData, CByteString("filename="))
nPosBound = InstrB(nPosEnd, biData, vDataBounds)
If nPosFile <> 0 And nPosFile < nPosBound Then
Dim oUploadFile, sFileName
Set oUploadFile = New UploadedFile
nPosBegin = nPosFile + 10
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sFileName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
oUploadFile.FileName = Right(sFileName, Len(sFileName)-InStrRev(sFileName, "\"))
Dim oFileExtension
If sFileName <> "" then
oFileExtension = (Right(sFileName, Len(sFileName)-InStrRev(sFileName, ".")))
If oFileExtension <> "jpg" AND oFileExtension <> "jpeg" AND oFileExtension <> "gif" AND oFileExtension <> "pdf" then
response.write("<h1>Post New File</h1><p><font color=#ff0000>An error has occurred while processing your request.<br><br>We are sorry, Extensions other than JPG, JPEG, Gif, PDF are not allowed to upload<p><b>Click <a href='javascript:history.go(-1);'>here</a> to go back and address the error.</b></font>")
response.end
Exit Sub
End if
end If
nPos = InstrB(nPosEnd, biData, CByteString("Content-Type:"))
nPosBegin = nPos + 14
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
oUploadFile.ContentType = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosBegin = nPosEnd+4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
oUploadFile.FileData = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
If sfileName <> "" then
If oUploadFile.FileSize > 10000000 Then
response.write("<h1>Post New Image</h1><p><font color=#ff0000>An error has occurred while processing your request.<br><br>We are sorry, Upload file containing 10000000(10mb) bytes only.<p><b>Click <a href='javascript:window:history.go(-1);'>here</a> to go back and address the error.</b></font>")
response.end
Exit Sub
End if
End if
If oUploadFile.FileSize > 0 Then Files.Add LCase(sInputName), oUploadFile
Else
nPos = InstrB(nPos, biData, CByteString(Chr(13)))
nPosBegin = nPos + 4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
If Not mcolFormElem.Exists(LCase(sInputName)) Then mcolFormElem.Add LCase(sInputName), CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
End If
nDataBoundPos = InstrB(nDataBoundPos + LenB(vDataBounds), biData, vDataBounds)
Loop
End Sub
'String to byte string conversion
Private Function CByteString(sString)
Dim nIndex
For nIndex = 1 to Len(sString)
CByteString = CByteString & ChrB(AscB(Mid(sString,nIndex,1)))
Next
End Function
'Byte string to string conversion
Private Function CWideString(bsString)
Dim nIndex
CWideString =""
For nIndex = 1 to LenB(bsString)
CWideString = CWideString & Chr(AscB(MidB(bsString,nIndex,1)))
Next
End Function
End Class
Class UploadedFile
Public ContentType
Public FileName
Public FileData
Public Property Get FileSize()
FileSize = LenB(FileData)
End Property
Public Sub SaveToDisk(sPath)
Dim oFS, oFile
Dim nIndex
If sPath = "" Or FileName = "" Then Exit Sub
If Mid(sPath, Len(sPath)) <> "\" Then sPath = sPath & "\"
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If Not oFS.FolderExists(sPath) Then Exit Sub
Set oFile = oFS.CreateTextFile(sPath & FileName, True)
For nIndex = 1 to LenB(FileData)
oFile.Write Chr(AscB(MidB(FileData,nIndex,1)))
Next
oFile.Close
End Sub
Public Sub SaveToDatabase(ByRef oField)
If LenB(FileData) = 0 Then Exit Sub
If IsObject(oField) Then
oField.AppendChunk FileData
End If
End Sub
End Class
%>
submit.asp
<!-- #include file="upload.asp" -->
<%
response.buffer = true
Dim Uploader, File, i, j
Set Uploader = New FileUploader
Uploader.Upload()
Dim brandnm, filename
brandnm = Uploader.form("brandname")
Dim objRSa, objCmda, stra
Set objCmda = server.CreateObject("adodb.connection")
Set Objrsa = Server.CreateObject("ADODB.Recordset")
objCmda.open MM_connDUdirectory_STRING
stra = "SELECT * FROM brand"
Objrsa.Open stra,objCmda,1,2
if Uploader.Files.count <> 0 then
File = Uploader.Files.Items()
File(0).SavetoDisk Server.MapPath("upload/brands") 'Folder path where image will save
filename = File(0).Filename
else
filename = ""
End if
Objrsa.addnew
Objrsa.fields("brand_name") = brandnm
Objrsa.fields("brand_createddt") = now()
if filename <>"" then Objrsa.fields("brand_picpath") = filename
For Each File In Uploader.Files.Items
Objrsa("brand_ctype") = File.ContentType
next
Objrsa.Update
Objrsa.Close
Set Objrsa = Nothing
set objCmda = Nothing
%>
Please help me out of this issue.
If you want to rename it to follow a known pattern as in your example ("filename(number).ext"), you must to use a pseudo-code like this:
let counter = 1
let original = file(0).Filename
let current = file(0).Filename
while(current file exists)
current = original-without-extension + (counter) + original-extension
counter = counter + 1
end
However, I think that would be better to store the user provided filename into your database and choose a random-like filename to store the actual file into the filesystem.
let current = userLogin + (currentTime as yyyyMMddHHmmss) + ".uploaded"
By using a bogus file extension you make your application way more secure, as your file will not be interpretable/executable -- imagine a malicious user uploading an .ASP file and executing it.
If this break the image MIME type, you should consider creating another .ASP page read the database to discover the appropriate MIME type based on the user provided file extension, write that content-type and the binary file content.
TL;DR: don't use the user provided file name, create a new one. This will avoid server hacking.
I have some Excel x64 VBA code that gets MP3 files, along with track#, size, length, etc., and puts them in some worksheets. The basic code came from John Walkenbach's page and can be found here: http://spreadsheetpage.com/index.php/file/mp3_file_lister/. I have modified it to run in 64-bit Excel by adding the PtrSafe keyword in the function declarations and changing some data types from Long to either LongLong or LongPtr (and maybe a few others). The code works wonderfully with one not too minor exception, it will not return any files in folders that contain leading periods. For example, I have an album by .38 Special ripped using WMP. The folder is: D:\Users\username\Music\Music.38 Special\Rock & Roll Strategy... This path does not appear in the list generated. I also have: D:\Users\username\Music\Music\Norah Jones...Featuring Nora Jones... and this folder is missing, too (the trailing ellipses represent the list of songs) . I have contacted John Walkenbach via email, and he has no idea why this is happening either.
Here is the code as I've modified it:
Option Explicit
Dim Sht1Row As Integer
Dim Sht2Row As Integer
' By John Walkenbach
' Maybe be distributed freely, but not sold
'API declarations
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type
Sub GetAllFiles()
Dim Msg As String
Dim Directory As String
Dim lastRow1C As Integer
Dim lastRow2C As Integer
Dim lastRow1D As Integer
Dim lastRow2D As Integer
Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) "\" Then Directory = Directory & "\"
With Sheet1
lastRow1C = .Cells(.Rows.Count, "C").End(xlUp).Row
If lastRow1C lastRow2D Then
.Range("D" & lastRow2D, "F" & lastRow2D).Select
Selection.AutoFill Destination:=Range("D" & lastRow2D, "F" & lastRow2C)
End If
.Range("E2:E" & lastRow2C).Copy
.Range("A2:A" & lastRow2C).PasteSpecial xlPasteValues
Columns("A:J").Sort key1:=Range("G2"), order1:=xlAscending, key2:=Range("H2"), order2:=xlAscending, Header:=xlYes
Range("A1").Select
End With
With Sheet1
Worksheets("Music_Library_Full").Activate
lastRow1C = .Cells(.Rows.Count, "C").End(xlUp).Row
lastRow1D = .Cells(.Rows.Count, "D").End(xlUp).Row
If lastRow1C > lastRow1D Then
.Range("D" & lastRow1D, "F" & lastRow1D).Select
Selection.AutoFill Destination:=Range("D" & lastRow1D, "F" & lastRow1C)
End If
.Range("E2:E" & lastRow1C).Copy
.Range("A2:A" & lastRow1C).PasteSpecial xlPasteValues
Columns("A:J").Sort key1:=Range("G2"), order1:=xlAscending, key2:=Range("H2"), order2:=xlAscending, Header:=xlYes
Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As String
Dim x As String
Dim pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Public Sub RecursiveDir(ByVal currdir As String)
Dim Dirs() As Variant
Dim NumDirs As Long
Dim FileName As String
Dim PathAndName As String
Dim i As Long
Dim PathName As String
Dim TrackNum As Variant
Dim Genre As String
Dim Duration As Variant
Dim FileSize As Variant
' Make sure path ends in backslash
If Right(currdir, 1) "\" Then currdir = currdir & "\"
' Put column headings on active sheet
Worksheets("Music_Library_Full").Activate
Cells(1, 1) = "Artist & Filename Lookup"
Cells(1, 2) = "Filename Lookup"
Cells(1, 3) = "Full Pathname"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Artist & Filename"
Cells(1, 6) = "Filename"
Cells(1, 7) = "Path"
Cells(1, 8) = "Track#"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Size"
Range("1:1").Font.Bold = True
Range("1:1").Font.Italic = True
Range("1:1").Font.Name = "Consolas"
Worksheets("Best_Greatest").Activate
Cells(1, 1) = "Artist & Filename Lookup"
Cells(1, 2) = "Filename Lookup"
Cells(1, 3) = "Full Pathname"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Artist & Filename"
Cells(1, 6) = "Filename"
Cells(1, 7) = "Path"
Cells(1, 8) = "Track#"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Size"
Range("1:1").Font.Bold = True
Range("1:1").Font.Italic = True
Range("1:1").Font.Name = "Consolas"
' Get files
FileName = Dir(currdir & "*.*", vbDirectory)
Do While Len(FileName) 0
If Left$(FileName, 1) "." Then 'Current dir
PathAndName = currdir & FileName
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
'store found directories
ReDim Preserve Dirs(0 To NumDirs) As Variant
Dirs(NumDirs) = PathAndName
NumDirs = NumDirs + 1
Else
If UCase(Right(FileName, 3)) = "MP3" Then
PathName = currdir 'path
FileName = FileName 'filename
TrackNum = FileInfo(currdir, FileName, 26) 'track
Duration = FileInfo(currdir, FileName, 27) 'duration
FileSize = Application.Round(FileLen(currdir & FileName) / 1024, 0) 'size
'Application.StatusBar = Row
If InStr(1, LCase(PathName), LCase("Best of"), vbTextCompare) Or InStr(1, LCase(PathName), LCase("Greatest"), vbTextCompare) Then
'Sht2Row = WorksheetFunction.CountA(Range("C:C")) + 1
Worksheets("Best_Greatest").Activate
Cells(Sht2Row, 2) = FileName
Cells(Sht2Row, 3) = PathName & FileName
Cells(Sht2Row, 7) = PathName
Cells(Sht2Row, 8) = TrackNum
Cells(Sht2Row, 9) = Duration
Cells(Sht2Row, 10) = FileSize
Sht2Row = Sht2Row + 1
Else
'Sht1Row = WorksheetFunction.CountA(Range("C:C")) + 1
Worksheets("Music_Library_Full").Activate
Cells(Sht1Row, 2) = FileName
Cells(Sht1Row, 3) = PathName & FileName
Cells(Sht1Row, 7) = PathName
Cells(Sht1Row, 8) = TrackNum
Cells(Sht1Row, 9) = Duration
Cells(Sht1Row, 10) = FileSize
Sht1Row = Sht1Row + 1
End If
End If
End If
End If
FileName = Dir()
Loop
' Process the found directories, recursively
For i = 0 To NumDirs - 1
RecursiveDir Dirs(i)
Next i
End Sub
Function FileInfo(path, FileName, item) As Variant
Dim objShell As IShellDispatch4
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(path)
Set objFolderItem = objFolder.ParseName(FileName)
FileInfo = objFolder.GetDetailsOf(objFolderItem, item)
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
If anyone has any idea how to modify this so that pathnames containing a leading period as any part of the path can be returned, I'd be very glad to see it. I'd just rename those particular paths by removing the leading periods, but I'm afraid WMP will just one day put everything back the way it was (has happened before). Also, if you pick the actual folder in the BrowseForFolder API, that folder with the leading periods actually makes it into the sheet, but of course, only that folder.
Thanks
Look at this line in your code sample:
If Left$(FileName, 1) "." Then 'Current dir
Since the current directory is defined as a single '.' character, and this code only checks the initial character, it drops out before recursively examining it. Change the condition to check the length of the string as well as the initial character, e.g.
If (Left$(FileName, 1) = "." And FileName.Length = 1) Then 'Current dir
N.B. This code has not been tested; I hope it works for your use.
I was able to fix this by separating the test for root and subdirectory into separate IF statements, i.e.:
If filename <> "." Then
If filename <> ".." Then
*Code here*
End If
End If
Might be clunky, but it works.
The original If statement was:
If filename <> "." or filename <> ".." Then
This never worked. But then it occurred to me that maybe I needed to use a NAND statement. NAND = Not And. So I tried this:
if Not filename = "." And Not Filename = ".." then
This actually worked and seems to execute more rapidly than the earlier solution.
Option Explicit
' By John Walkenbach
' Maybe be distributed freely, but not sold
Sub GetAllFiles()
Dim Msg As String
Dim Directory
Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
Set Directory = Application.FileDialog(msoFileDialogFolderPicker)
With Directory
.Title = Msg
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Directory = .SelectedItems.item(1)
Else
Exit Sub
End If
End With
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
Worksheets("Sheet1").Activate
Cells.Clear
' Put column headings on active sheet
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "FullPath"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Album"
Cells(1, 6) = "Title"
Cells(1, 7) = "Track#"
Cells(1, 8) = "Genre"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Year"
Cells(1, 12) = "Size"
Range("1:1").Font.Bold = True
Call RecursiveDir(Directory)
End Sub
Public Sub RecursiveDir(ByVal currdir As String)
Dim Dirs() As Variant
Dim NumDirs As Long
Dim filename As String
Dim PathAndName As String
Dim i As Variant
Dim Row As Variant
' Make sure path ends in backslash
If Right(currdir, 1) <> "\" Then currdir = currdir & "\"
Application.ScreenUpdating = False
' Get files
filename = Dir(currdir & "*.*", vbDirectory)
Do While Len(filename) <> 0
DoEvents
If Not filename = "." And Not filename = ".." Then 'Current dir
PathAndName = currdir & filename
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
'store found directories
ReDim Preserve Dirs(0 To NumDirs) As Variant
Dirs(NumDirs) = PathAndName
NumDirs = NumDirs + 1
Else
If UCase(Right(filename, 3)) = "MP3" Then
Row = WorksheetFunction.CountA(Range("A:A")) + 1
Cells(Row, 1) = currdir 'path
Cells(Row, 2) = filename 'filename
Cells(Row, 3) = PathAndName
Cells(Row, 4) = FileInfo(currdir, filename, 20) 'artist
Cells(Row, 5) = FileInfo(currdir, filename, 14) 'album
Cells(Row, 6) = FileInfo(currdir, filename, 21) 'title
Cells(Row, 7) = FileInfo(currdir, filename, 26) 'track
Cells(Row, 8) = FileInfo(currdir, filename, 16) 'genre
Cells(Row, 9) = FileInfo(currdir, filename, 27) 'duration
Cells(Row, 10) = FileInfo(currdir, filename, 15) 'Year
Cells(Row, 11) = FileInfo(currdir, filename, 5)
Cells(Row, 12) = Application.Round(FileLen(currdir & filename) / 1024, 0) 'size
Application.StatusBar = Row
End If
End If
End If
filename = Dir()
Loop
' Process the found directories, recursively
For i = 0 To NumDirs - 1
RecursiveDir Dirs(i)
Next i
Application.StatusBar = False
End Sub
Function FileInfo(path, filename, item) As Variant
Dim objShell As IShellDispatch4
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(path)
Set objFolderItem = objFolder.ParseName(filename)
FileInfo = objFolder.GetDetailsOf(objFolderItem, item)
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Also, other fileinfo items: 27 = duration, 28 = bit rate, 26 = track number.
I currently have code written to take the fields of one workbook and copy into another workbook. I currently take a range and 'snapshot' it then save that as a separate .bmp file.
I also would like to take this snapshot and attach it into a cell of the workbook I'm copying everything over into. Anybody have any advice, or see here i can add code for this?
Sub Macro4()
'
' Record and File report
Dim Model As String
Dim IssueDate As String
Dim ConcernNo As String
Dim IssuedBy As String
Dim FollowedSEC As String
Dim FollowedBy As String
Dim RespSEC As String
Dim RespBy As String
Dim Timing As String
Dim Title As String
Dim PartNo As String
Dim Block As String
Dim Supplier As String
Dim Other As String
Dim Detail As String
Dim CounterTemp As String
Dim CounterPerm As String
Dim VehicleNo As String
Dim OperationNo As String
Dim Line As String
Dim Remarks As String
Dim ConcernMemosMaster As Workbook
Dim LogData As String
Dim newFile As String
Dim fName As String
Dim Filepath As String
Dim DTAddress As String
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
'Determines if any required cells are empty and stops process if there are. displays error message.
If IsEmpty(Range("c2")) Or IsEmpty(Range("AT3")) Or IsEmpty(Range("BI2")) Or IsEmpty(Range("M7")) Or IsEmpty(Range("C10")) Or IsEmpty(Range("AP14")) Or IsEmpty(Range("C14")) Or IsEmpty(Range("C23")) Or IsEmpty(Range("C37")) Or IsEmpty(Range("J51")) Or IsEmpty(Range("AA51")) Or IsEmpty(Range("C55")) Or IsEmpty(Range("AR51")) Then
MsgBox "Please fill out all required fields and retry.", vbOKOnly
Exit Sub
End If
If Dir("N:\") = "" Then '"N" drive not found, abort sub
MsgBox "Error: Drive, path or file not found. Please email copy of file to: "
Exit Sub
End If
'assigns fields
Worksheets("ConcernMemo").Select
Model = Range("c2")
IssueDate = Range("AT3")
ConcernNo = Range("BC3")
IssuedBy = Range("BI2")
FollowedSEC = Range("BA9")
FollowedBy = Range("BD9")
RespSEC = Range("BG9")
RespBy = Range("BJ9")
Timing = Range("M7")
Title = Range("C10")
PartNo = Range("AP14")
Block = Range("AP16")
Supplier = Range("AP18")
Other = Range("AZ14")
Detail = Range("C14")
CounterTemp = Range("C23")
CounterPerm = Range("C37")
VehicleNo = Range("J51")
OperationNo = Range("AA51")
Remarks = Range("C55")
Line = Range("AR51")
LogData = Format(Now(), "mm_dd_yyyy_hh_mmAMPM")
fName = Range("BC3").Value
newFile = fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM")
Filepath = "N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM")
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
'asks user is they are ready to send to database
If MsgBox("Are you ready to send record to database?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set pic_rng = Worksheets("ConcernMemo").Range("AK22:BK49")
Set ShTemp = Worksheets.Add
'Takes snapshot of image/sketch and saves to sharedrive
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Images\" & newFile & ".bmp", FilterName:="bmp"
ShTemp.Delete
'opens db file on sharedrive and copies fields over
Set ConcernMemosMaster = Workbooks.Open("N:\Newell K\Concern_Memo\concern_memos_DBMASTER.xlsx")
Worksheets("sheet1").Select
Worksheets("sheet1").Range("a1").Select
RowCount = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count
With Worksheets("sheet1")
.Range("a1").Offset(RowCount, 0) = Model
.Range("b1").Offset(RowCount, 0) = IssueDate
.Range("c1").Offset(RowCount, 0) = ConcernNo
.Range("d1").Offset(RowCount, 0) = IssuedBy
.Range("e1").Offset(RowCount, 0) = FollowedSEC
.Range("f1").Offset(RowCount, 0) = FollowedBy
.Range("g1").Offset(RowCount, 0) = RespSEC
.Range("h1").Offset(RowCount, 0) = RespBy
.Range("i1").Offset(RowCount, 0) = Timing
.Range("j1").Offset(RowCount, 0) = Title
.Range("k1").Offset(RowCount, 0) = PartNo
.Range("l1").Offset(RowCount, 0) = Block
.Range("m1").Offset(RowCount, 0) = Supplier
.Range("n1").Offset(RowCount, 0) = Other
.Range("o1").Offset(RowCount, 0) = Detail
.Range("p1").Offset(RowCount, 0) = CounterTemp
.Range("q1").Offset(RowCount, 0) = CounterPerm
.Range("r1").Offset(RowCount, 0) = VehicleNo
.Range("s1").Offset(RowCount, 0) = OperationNo
.Range("t1").Offset(RowCount, 0) = Remarks
.Range("U1").Offset(RowCount, 0) = PicTemp
.Range("V1").Offset(RowCount, 0) = LogData
.Range("w1").Offset(RowCount, 0) = Filepath
.Range("x1").Offset(RowCount, 0) = Line
'saves a copy to of entire file to sharedrive
ThisWorkbook.SaveCopyAs fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & newFile & ".xlsm"
'Saves copy to desktop
Application.DisplayAlerts = True
ThisWorkbook.SaveCopyAs DTAddress & newFile & ".xlsm"
MsgBox "A copy has been saved to your desktop"
ThisWorkbook.SendMail Recipients:="kaitlin.newell#nissan-usa.com", _
Subject:="New Concern Memo"
End With
ConcernMemosMaster.Save
ConcernMemosMaster.Close
Application.DisplayAlerts = True
MsgBox "Please close out file without saving"
End Sub
Try this out :
Range("A1:D4").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Range("A6").PasteSpecial
It will paste a copy of the "snapshot" of Range("A1:D4") at the cell A6.
EDIT : Since you have already set an object of that "target" workbook, you can use it to easily paste into it. Try this :
ConcernMemosMaster.Worksheets("sheet1").Range("A1:X1").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
ConcernMemosMaster.Worksheets("sheet1").Range("B1").PasteSpecial
I want to to create a full path directory, like "C:\temp1\temp2\temp2" without having to make multiple "MakeDir", for each directory.
Is this possible?
Is there any reference that I can add to my project that has this kind of function?
Thanks
You can use these functions to make the task a little easier:
Const PATH_SEPARATOR As String = "\"
'"' Creates a directory and its parent directories '''
Public Sub MakeDirectoryStructure(strDir As String)
Dim sTemp As String
If Right$(strDir, 1) = PATH_SEPARATOR Then
sTemp = Left$(strDir, Len(strDir) - 1)
Else
sTemp = strDir
End If
If Dir(strDir, vbDirectory) <> "" Then
' Already exists.'
Else
'We have to create it'
On Error Resume Next
MkDir strDir
If Err > 0 Then
' Create parent subdirectory first.'
Err.Clear
'New path'
sTemp = ExtractPath(strDir)
'Recurse'
MakeDirectoryStructure sTemp
End If
MkDir strDir
End If
End Sub
Public Function ExtractPath(strPath As String) As String
ExtractPath = MiscExtractPathName(strPath, True)
End Function
Private Function MiscExtractPathName(strPath As String, ByVal bFlag) As String
'The string is treated as if it contains '
'a path and file name. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If bFlag = TRUE: '
' Function extracts the path from '
' the input string and returns it. '
' If bFlag = FALSE: '
' Function extracts the File name from '
' the input string and returns it. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim lPos As Long
Dim lOldPos As Long
'Shorten the path one level'
lPos = 1
lOldPos = 1
Do
lPos = InStr(lPos, strPath, PATH_SEPARATOR)
If lPos > 0 Then
lOldPos = lPos
lPos = lPos + 1
Else
If lOldPos = 1 And Not bFlag Then
lOldPos = 0
End If
Exit Do
End If
Loop
If bFlag Then
MiscExtractPathName = Left$(strPath, lOldPos - 1)
Else
MiscExtractPathName = Mid$(strPath, lOldPos + 1)
End If
End Function ' MiscExtractPathName'
I'm not sure where I got this code.
Asked and answered before:
equivalent-of-directory-createdirectory-in-vb6
Private Declare Function MakeSureDirectoryPathExists Lib
"imagehlp.dll" (ByVal lpPath As String) As Long
Dim mF As String
mF = FolderPath
If Right(mF, 1) <> "\" Then
mF = mF & "\"
MakeSureDirectoryPathExists mF
End If
'//Create nested folders in one call
Public Function MkDirs(ByVal PathIn As String) _
As Boolean
Dim nPos As Long
MkDirs = True 'assume success
If Right$(PathIn, 1) <> "\" Then PathIn = PathIn + "\" nPos = InStr(1, PathIn, "\")
Do While nPos > 0
If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then
On Error GoTo Failed
MkDir Left$(PathIn, nPos)
On Error GoTo 0
End If
nPos = InStr(nPos + 1, PathIn, "\")
Loop
Exit Function
Failed:
MkDirs = False
End Function