I have a code that copies a file from one location to another. What I would like it that when the file is copied, the recordID is placed in front of the file name (example: 150-FirstName). Here is the code I'm working with:
Private Sub cmd_LocateFile_Click()
On Error GoTo Error_Handler
Dim sFile As String
Dim sFolder As String
sFile = FSBrowse("", msoFileDialogFilePicker, "All Files (*.*),*.*")
If sFile <> "" Then
sFolder = Application.CodeProject.path & "\" & sAttachmentFolderName & "\"
If FolderExist(sFolder) = False Then MkDir (sFolder)
If CopyFile(sFile, sFolder & GetFileName(sFile)) = True Then
Me.FullFileName = sFolder & GetFileName(sFile)
Else
End If
End If
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\cmd_LocateFile_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
Try with:
Dim Id As Long
Dim sTarget As String
Id = YourRecordID ' Set current record id.
sTarget = sFolder & CStr(Id) & "-" & GetFileName(sFile)
' Replace your current If-Then-Else-End If block.
If CopyFile(sFile, sTarget)) = True Then
Me!FullFileName.Value = sTarget
End If
Related
I have created a VB script that I am calling from my batch file on Windows 10. The script is something like this:
Set startupShortcut = sh.CreateShortcut("%ProgramData%\Microsoft\Windows\Start Menu\Programs\MyApplication.lnk")
startupShortcut.IconLocation = "C:\Users\MyUser\MyApplication\resources\MyApplication.ico"
startupShortcut.TargetPath = "C:\Users\MyUser\MyApplication\MyApplication-1.4.4.jar"
startupShortcut.WorkingDirectory = "C:\Users\MyUser\MyApplication"
startupShortcut.Save
The shortcut path here has a space in "Start Menu" string. Running it does not create any shortcut at the mentioned path, but when I use a path without shortcut for eg. Desktop, it works fine.
I really need help to understand how I can use paths having space in them.
Here is a subroutine example that can be used for creating a shortcut :
Option Explicit
Const Title = "Create a shortcut for the current vbscript or any other application with arguments using an array"
Call RunAsAdmin()
Create_Shortcut Array("Desktop","Recent","shell:Recent")
Create_Shortcut Array("Desktop","User profile","%userprofile%")
Create_Shortcut Array(_
"Desktop",_
"NetworkDiagnostics",_
"%SystemRoot%\system32\msdt.exe",_
"-skip TRUE -path %Windir%\diagnostics\system\networking -ep NetworkDiagnosticsPNI",_
"%SystemRoot%\system32\msdt.exe,0",_
"Network Diagnostics to fix connections problems",_
"CTRL+ALT+D"_
)
'-------------------------------------------------------------------------------------------------------
Sub Create_Shortcut(rArgs)
Dim objShell,objShortCut,ObjShortcutPath,ShortcutName,ShortcutPath,ShortcutLocation
Dim TargetPath,Arguments,IconLocation,Description,HotKey
Set objShell = CreateObject("WScript.Shell")
If UBound(rArgs) > 1 Then
ShortcutLocation = cstr(rArgs(0))
ShortcutPath = objShell.SpecialFolders(ShortcutLocation)
ShortcutName = cstr(rArgs(1))
Set objShortCut = objShell.CreateShortcut(ShortcutPath & "\" & ShortcutName & ".lnk")
TargetPath = objShell.ExpandEnvironmentStrings(rArgs(2))
objShortCut.TargetPath = TargetPath
If ShortcutPath = "" Then
MsgBox "Error The Shortcut Path Does Not Exsists On Your System."_
,vbCritical+vbSystemModal,Title
wscript.quit(1)
End If
End If
If UBound(rArgs) > 2 Then
Arguments = cstr(rArgs(3))
objShortCut.Arguments = Arguments
End If
If UBound(rArgs) > 3 Then
IconLocation = cstr(rArgs(4))
ObjShortCut.IconLocation = IconLocation
End If
If UBound(rArgs) > 4 Then
Description = cstr(rArgs(5))
ObjShortCut.Description = Description
End If
If UBound(rArgs) > 5 Then
HotKey = cstr(rArgs(6))
ObjShortCut.HotKey = HotKey
End If
objShortCut.Save
On Error Resume Next
If Err.Number <> 0 Then
ShowError()
Else
objShell.Popup "The Shortcut "& chr(34) & ShortcutName & chr(34) &" is created Successfully !"& vbcrlf &_
"On " & chr(34) & ShortcutPath & chr(34),5,Title,vbInformation+vbSystemModal
End If
End Sub
'-------------------------------------------------------------------------------------------------------
Sub ShowError()
ErrDetail = "Description : " & Err.Description & vbCrlf & _
"Error number : " & Err.Number & vbCrlf & _
"Error source : " & Err.Source
MsgBox ErrDetail,vbCritical+vbSystemModal,Title
Err.clear
End Sub
'-------------------------------------------------------------------------------------------------------
Sub RunAsAdmin()
If Not WScript.Arguments.Named.Exists("elevate") Then
CreateObject("Shell.Application").ShellExecute WScript.FullName _
, chr(34) & WScript.ScriptFullName & chr(34) & " /elevate", "", "runas", 1
WScript.Quit
End If
End Sub
'-------------------------------------------------------------------------------------------------------
I used & to connect 2 paths with spaces and it worked well for me:
startupShortcutPath = "C:\ProgramData\Microsoft\Windows\" & "\Start Menu\Programs\MyApplication\MyApplication.lnk"
I have put together a script that I think will work, but the only code I know is some VBA. Never tried to create a vbscript before, so my apologies if some errors are obvious, but pointers and corrections would be appreciated.
I am hoping I can give users in my company a link to this script and have them run it. It will create a folder on their C Drive, make it a trusted location, copy a database frontend from the server into it and create a shortcut on their desktop linking to the new file. (I'm hoping the file will auto-update when a new version is made - I think that bit works though).
The code comes from various sources, including my own addled mind but would I need to download Visual Studio to test this? Slightly concerned as it includes creating a registry key and I don't know how to stop the code if it all goes horribly wrong. I don't even know how to break a loop (although I think I read somewhere you need to hit Esc twice). Any tips on how to signify which sub is the main one to run on start would be good too.
EDIT : Code has been amended to my end result incase it is of use to others. Please use with caution. The 'update' vbs deletes the folder created on the local drive.
'FrontEnd Setup
call CreateTrustedFolder
'Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
'Const HKEY_LOCAL_MACHINE = &H80000002
'Const HKEY_USERS = &H80000003
'Const HKEY_CURRENT_CONFIG = &H80000005
Dim lclFolder
Dim blnUpdate
Sub CreateTrustedFolder()
On error resume next
Call RunAdmin
Call FolderFileShortcut
Call CreateReg
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
'Run as Administrator
Sub RunAdmin()
On error resume next
If Not WScript.Arguments.Named.Exists("elevate") Then
CreateObject("Shell.Application").ShellExecute WScript.FullName _
, WScript.ScriptFullName & " /elevate", "", "runas", 1
WScript.Quit
End If
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
'Check if folder exists, add file and desktop shortcut
Sub FolderFileShortcut()
On error resume next
Dim oWS
Dim FSO
Dim svrFolder
Dim myShortcut
Dim strLocalDB
Dim strServerDB
Dim strUpdate
Dim strIcon
Dim objFile
Dim counter
Set oWS = WScript.CreateObject("WScript.Shell")
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
svrFolder = "\\192.168.1.2\DeptFolder\DatabaseFolder\Auto-Update"
lclFolder = "C:\Program Files\Orrible Database"
If (FSO.FolderExists(lclFolder)) Then
oWS.run "icacls """ & lclFolder & """ /reset /grant:r Users:(W) /t" '/T required for existing folders
FSO.DeleteFolder lclFolder
blnUpdate = True
end if
If Not (FSO.FolderExists(svrFolder)) Then
msgbox "Unable to connect to Location Server", vbCritical, "Installation Failed"
WScript.Quit
End If
For Each objFile in FSO.Getfolder(svrFolder).Files
if LCase(FSO.GetExtensionName(objFile.name)) = LCase("mde") then
counter = counter + 1
strServerDB = FSO.GetFileName(objFile)
end if
Next
If strServerDB = "" or counter <> 1 then
msgbox "Unable to locate the Front End" & strServerDB & "-" & counter, vbCritical, "Installation Failed"
wScript.Quit
end if
strLocalDB = "Co Database.mde"
strUpdate = "DB_UpdateCheck.vbs"
strIcon = "Frontend Update.ico"
FSO.CreateFolder(lclFolder)
oWS.run "icacls """ & lclFolder & """ /grant Users:(OI)(CI)F /t" '/T required for existing folders
FSO.CopyFile svrFolder & "\" & strUpdate, lclFolder & "\" & strUpdate, True
FSO.CopyFile svrFolder & "\" & strServerDB, lclFolder & "\" & strLocalDB, True
FSO.CopyFile svrFolder & "\" & strIcon, lclFolder & "\" & strIcon, True
strDesktop = oWS.SpecialFolders("Desktop")
set myShortcut = oWS.CreateShortcut(strDesktop + "\New Database.lnk")
myShortcut.TargetPath = lclFolder & "\" & strUpdate
myShortcut.WindowStyle = 1
myShortcut.IconLocation = lclFolder & "\" & strIcon
myShortcut.WorkingDirectory = strDesktop
myShortcut.Save
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
Sub CreateReg()
On error resume next
Dim objRegistry 'registry object
Dim strDescription 'Description of the Trusted Location
Dim strParentKey 'Registry location of Application
Dim strNewKey 'strParentKey and myFolder
Dim oWS 'WSH shell object
strDescription = "DB Folder"
strParentKey = "Software\Microsoft\Office\15.0\Access\Security\Trusted Locations"
strNewKey = strParentKey & "\" & strDescription & "\"
Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
'objRegistry.GetStringValue HKEY_CURRENT_USER, strParentKey & "\" & strDescription
If Not objRegistry.EnumKey(HKEY_CURRENT_USER, strNewKey) = 0 then '0=true
objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey
objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", lclFolder
objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription
End if
If not blnUpdate = True then
msgbox "The Database is now available from your desktop", vbInformation, "Setup Complete"
Else
msgbox "The update is now complete."
End if
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
There is also a separate Update vbs which is what runs when the link is clicked. This checks to see if the 'created date' of the database on the server is newer than that on the local drive. The new DB name MUST NOT be the same as the one it is replacing. It might run a little fast, but this is as far as I have taken this.
Call CheckForUpdate
Sub CheckForUpdate()
On Error Resume Next
Dim FSO
Dim oWS
Dim svrFolder
Dim lclFolder
Dim svrFail
Dim strLocalDB
Dim strServerDB
Dim lclDate
Dim svrDate
Dim strFileName
Dim intDBcount
Dim fCheck
Set oWS = WScript.CreateObject("WScript.Shell")
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
svrFolder = "\\192.168.1.2\DeptFolder\DatabaseFolder\Auto-Update"
lclFolder = "C:\Program Files\Orrible Database"
strLocalDB = "Co Database.mde"
If Not (FSO.FolderExists(svrFolder)) Then
msgbox "Unable to connect to Location Server", vbCritical, "Update Check Failed"
svrFail = True
End If
If Not svrFail = True Then
For Each fCheck in FSO.GetFolder(svrFolder).Files
If Ucase(Right(fCheck.Name, 3)) = "MDE" Then
intDBcount = intDBcount + 1
strServerDB = fCheck.name
End If
Next
If Not intDBcount = 1 Then
MsgBox "Please inform the Administrator that there is a problem with the Automated Update System.", _
vbCritical, "Update Failed (" & intDBcount & ")"
svrFail = True 'not quit - need to see if old version available
End If
End If
If Not (FSO.FolderExists(lclFolder)) Then
If svrFail = True Then 'If no lcl folder or server
If Not intDBcount = 1 then WScript.Quit
msgbox "You are unable to use the Database." & vbcrlf & _
"Please try again when you have access to the Location Server.", _
vbcritical, "Database Not Installed"
WScript.Quit
Else 'If no lclfolder, get it from svr
'Do normal initial install
oWS.Run svrFolder & "\" & "DB_Install.vbs", 1, True
WScript.Quit
End If
Else
If svrFail = True Then 'If lcl folder, but no svr
'open db
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
Else 'If lcl folder and svr access, check for update.
lclDate = fso.getfile(lclFolder & "\" & strLocalDB).DateCreated
svrDate = fso.getfile(svrFolder & "\" & strServerDB).DateCreated
If lclDate < svrDate Then 'Update available
intMsg = MsgBox("An update is available - Do you wish to update now?", vbQuestion + vbYesNo, "Update Found")
If intMsg = vbYes Then
oWS.Run svrFolder & "\" & "DB_Install.vbs", 1, True ',1,true should pause the code until install closes
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
Else
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
End If
Else
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
End If
End If
End If
If err Then
MsgBox "The following error has occurred " & Err & " " & Err.Description
Exit Sub
End If
End Sub
i am creating a .vbs file that should open access, and inside access a form call "Issue Details", but passing a parameter, meaning that if i have 10 issues in my "Issues" table a vbs file is created for each one and when clicked should open the right record(would be one ID for each record in the table). It is so far opening access and it is opening the form(Issue Details) but it is blank. What am i missing? Help, getting crazy here ... Check code below. The weird thing here is that if i double click it again it will refresh and open the right record without opening anymore windows..
How can i fix that? I dont want to do it twice :)
Public Sub sendMRBmail(mrbid)
DoCmd.OpenForm "Issue Details", , , "[ID] = " & mrbid
End Sub
Private Sub Create_Click()
On Error GoTo Err_Command48_Click
Dim snid As Integer
snid = Me.ID
Dim filename As String
filename = "S:\Quality Control\vbs\QC" & snid & ".vbs"
Dim proc As String
proc = Chr(34) & "sendMRBmail" & Chr(34)
Dim strList As String
strList = "On Error Resume Next" & vbNewLine
strList = strList & "dim accessApp" & vbNewLine
strList = strList & "set accessApp = createObject(" & Chr(34) & "Access.Application" & Chr (34)")" & vbNewLine
strList = strList & "accessApp.OpenCurrentDataBase(" & Chr(34) & "S:\Quality Control\Quality DB\Quality Database.accdb" & Chr(34) & ")" & vbNewLine
strList = strList & "accessApp.Run " & proc & "," & Chr(34) & snid & Chr(34) & vbNewLine
strList = strList & "set accessApp = nothing" & vbNewLine
Open filename For Output As #1
Print #1, strList
Close #1
Err_Command48_Click:
If Err.Number <> 0 Then
MsgBox "Email Error #: " & Err.Number & ", " & "Description: " & Err.Description
Exit Sub
End If
End Sub
Found the problem. Changed instruction below, adding acFormEdit to it and it worked:
DoCmd.OpenForm "Issue Details", , , "[ID] = " & mrbid, acFormEdit
i am creating a .vbs file that should open access, and inside access a form call "Issue Details", but passing a parameter, meaning that if i have 10 issues in my "Issues" table a vbs file is created for each one and when clicked should open the right form id(would be one ID for each in the table). It is so far opening access and it is opening the form(Issue Details) but it is blank. What am i missing? Help, getting crazy here ... Check code below
Public Sub sendMRBmail(mrbid)
Dim tmprs As DAO.Recordset
Dim db As DAO.Database
Set db = CurrentDb
Set tmprs = db.OpenRecordset("select * from Issues where [ID] = " & mrbid)
If IsNull(tmprs) Then
MsgBox "Record is not yet available"
Else
DoCmd.OpenForm "Issue Details", , , "[ID] = " & mrbid
End If
Set tmprs = Nothing
End Sub
Private Sub Create_Click()
On Error GoTo Err_Command48_Click
Dim snid As Integer
snid = Me.ID
Dim filename As String
filename = "S:\Quality Control\vbs\QC" & snid & ".vbs"
Dim proc As String
proc = Chr(34) & "sendMRBmail" & Chr(34)
Dim strList As String
strList = "On Error Resume Next" & vbNewLine
strList = strList & "dim accessApp" & vbNewLine
strList = strList & "set accessApp = createObject(" & Chr(34) & "Access.Application" & Chr(34)")" & vbNewLine
strList = strList & "accessApp.OpenCurrentDataBase(" & Chr(34) & "S:\Quality Control\Quality DB\Quality Database.accdb" & Chr(34) & ")" & vbNewLine
strList = strList & "accessApp.Run " & proc & "," & Chr(34) & snid & Chr(34) & vbNewLine
strList = strList & "set accessApp = nothing" & vbNewLine
Open filename For Output As #1
Print #1, strList
Close #1
Err_Command48_Click:
If Err.Number <> 0 Then
MsgBox "Email Error #: " & Err.Number & ", " & "Description: " & Err.Description
Exit Sub
End If
End Sub
I already found the answer. I added acFormEdit at the end of my DoCmd and it worked, check below:
DoCmd.OpenForm "Issue Details", , , "[ID] = " & mrbid, acFormEdit
I wrote a small script to help re-organize my .mp3 collection. When I run this script, sometimes it will process several thousand files till it would hit an error condition (normally a move of a file that had a special character in its name/path that I hadn't counted for), but it would often exit the script with the text
Script execution time was exceeded on script "C:\DevSpace\mp3move.vbs".
Script execution was terminated.
Im not sure why this is happening. In an effort to figure out where this occured I added several msgbox lines, and what I found is that a msgbox would popup, but then it would auto-close very quickly.
Here is the code - i appoligize for not getting the formatting correctly in the forum
'Takes all .MP3 files in the source dir, reads the Artist tag associated with that file
'Checks for a dir named after the artist in the destination dir
'If the folder artist/album does not exists, it will create it
'Then move the .mp3 file to the dest dir
Dim oAppShell, oFSO, oFolder, oFolderItems
Dim strPath, i
Dim sInfo
iDebug=0
sInfo = "Item Description"
strPath = "K:\_preprocess"
sDestination = "K:\Music"
Set oAppShell = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If not oFSO.FolderExists(strPath) Then
WScript.Echo "Folder " & strPath & " is inaccessble"
End If
Set oFolder = oAppShell.NameSpace(strPath)
Set oFolderItems = oFolder.Items()
sCreate = ""
sExist = ""
sMoved = ""
If (not oFolderItems is nothing) Then
if oFolderItems.Count = 0 then
Wscript.echo "no files found in this folder: " & strPath
WScript.Quit
end If
If iDebug = 1 Then
i = oFolderItems.count
WScript.Echo i
End If
For Each oItem in oFolderItems
If iDebug = 1 Then
i = i - 1
End If
If oItem.Type = "MP3 audio file (mp3)" or oItem.Type = "MP3 Format Sound (.mp3)"_
Or oItem.Type = "Windows Media Audio file" or oItem.Type = "MP3 Format Sound" then
'get artist name
sArtist = oFolder.GetDetailsOf(oItem, 20)
If iDebug = 1 Then
MsgBox oItem.name
MsgBox sArtist
End If
'if 'The Beatles' change to 'Beatles, the'
If InStr(LCase(sArtist),"the") = 1 Then
sArtist = Mid(sArtist,5) & ", the"
End If
'remove \ from band name
If InStr(sArtist,"\") > 0 Then
sArtist = Replace(sAlbum,"\","")
End If
If InStr(sArtist,"/") > 0 Then
sArtist = Replace(sAlbum,"/","")
End If
If iDebug = 1 Then
MsgBox sArtist
End If
'if folder does not exist create
'MsgBox sDestination & "\" & sArtist
If oFSO.FolderExists(sDestination & "\" & sArtist) Then
'MsgBox "EXIST"
sExist = sExist & sDestination & "\" & sArtist & " exists" & vbCrLf
Else
'MsgBox "CREATE " & sDestination & "\" & sArtist
rtn = oFSO.CreateFolder(sDestination & "\" & sArtist)
sCreate = sCreate & sDestination & "\" & sArtist & " created" & vbCrLf
End If
'get album name
sAlbum = oFolder.GetDetailsOf(oItem, 14)
'remove special characters from album name
If InStr(sAlbum,":") > 0 Then
sAlbum = Replace(sAlbum,":","")
End if
If InStr(sAlbum,"?") > 0 Then
sAlbum = Replace(sAlbum,"?","")
End If
If InStr(sAlbum,"...") > 0 Then
sAlbum = Replace(sAlbum,"...","")
End If
If InStr(sAlbum,"/") > 0 Then
sAlbum = Replace(sAlbum,"/","")
End If
If InStr(sAlbum,"\") > 0 Then
sAlbum = Replace(sAlbum,"\","")
End If
'create dir artist/album
If oFSO.FolderExists (sDestination & "\" & sArtist & "\" & sAlbum) Then
'sExist = sExist & sDestination & "\" & sArtist & sAlbum & " exists" & vbCrLf
Else
'MsgBox sDestination & "\" & sArtist & "\" & sAlbum
rtn = oFSO.CreateFolder (sDestination & "\" & sArtist & "\" & sAlbum)
'sCreate = sCreate & sDestination & "\" & sArtist & " created" & vbCrLf
End If
'move file
sSource = strPath & "\" & oItem.name & ".mp3"
sDest = sDestination & "\" & sArtist & "\" & sAlbum & "\"
If iDebug=1 Then
MsgBox sSource & vbCrLf & sDest
End If
If oFSO.FileExists (sSource) Then
oFSO.MoveFile sSource, sDest
'sMoved = sMoved & sSource & " moved to " & sDest & vbcrlf
'MsgBox smoved
Else
MsgBox sSource & " not moved"
End If
End If
If iDebug = 1
WScript.Sleep 1000
WScript.Echo i
End If
Next
If iDebug=1
WScript.Echo i
End if
'MsgBox sCreate
'MsgBox sExist
'MsgBox sMoved
End If
You should set the WScript.Timeout property to a higher value.
See example here
The problem existed with my input files. Some of the .mp3 files I was using to test with had non-ascii characters in the tags, and that caused the program to freeze