I'm pulling my hair out on this one.
I put together some code for opening a file associated with records in our database. Newer data has full file paths stored as text in a separate table. Old data does not have a full file path but has enough details to assemble a working path in most cases.
My code checks to see if the older data fields are null and if they are proceed to the newer filepath.
The problem I'm having is with DLookup in the IF statement being stuck on the first file it was used on. No matter what I do, DLookup always returns the same result as the first time I ran the code. I'm stumped.
Private Sub btnOpenFile_Click()
Dim FacID As String
Dim FacIDShort As String
Dim CDID As String
Dim FileName As String
Dim FileURL As String
FacID = [FAC_ID]
FacIDShort = Left(FacID, 4)
On Error GoTo ErrHandler
If IsNull([CD_NUM]) Then ' Checks to see if old file path exists before trying new file path
FileURL = DLookup("[File_Path]", "tblFileDirectory", "[Drawing_ID]")
Application.FollowHyperlink (FileURL)
Else
CDID = [CD_NUM]
FileName = [FILENAME]
FileURL = ("\\SYSTEMXXX\" & FacIDShort & "\" & FacID & "\FILES\" & CDID & "\" & FileName)
Application.FollowHyperlink (FileURL)
End If
Exit Sub
ErrHandler:
LogError (FileURL)
MsgBox ("Error: " & FileURL & vbNewLine & "The URL Does Not Exist.")
End Sub
DLookup("[File_Path]", "tblFileDirectory", "[Drawing_ID]" should actually be more like DLookup("[File_Path]", "tblFileDirectory", "MyDrawingIdColumnInTable = MyDrawingIdToLookFor"
Related
I have a list of file names in a worksheet. I want to read a name, find the actual file, rename it and move on to the next name.
The 1st part, retrieving the name from the worksheet and modifying it to the new name is not a problem. The problem is assigning the new name to the file.
The Name function does not work because the files are on a different drive. I also tried Scripting.FileSystemObject.
The code runs but no change is made.
Here is the code I used...
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.GetFile(fOldName)
If Not Err = 53 Then 'File not found
'Rename file
f.Name = fNewName
End If
Did I make a code mistake I'm not seeing? Should I be using/doing something else?
Finding info on VBA and/or VB6 is getting pretty rare these days.
BTW. This is for Excel 2016.
Tks
If there was no misunderstanding...
FSO... it's bad in any case. It's just a bugsful API wrapper, written with a left chicken paw.
There are pure VB & API for more sophisticated cases.
No external libs & objects:
Public Sub sp_PrjFilMov()
Dim i As Byte
Dim sNam$, sExt$, sPthSrc$, sPthTgt$, sDir$
sPthSrc = "V:\"
sPthTgt = "R:\"
sNam = "Empty_"
sExt = ".dmy" ' dummy
For i = 1 To 5 ' create set of files for test
Call sx_CrtFil(i, sPthSrc, sNam, sExt)
Next
sDir = Dir(sPthSrc & "*" & sExt, vbNormal) ' lookup for our files ..
Do
'Debug.Print sDir
Select Case LenB(sDir)
Case 0
Exit Do ' *** EXIT DO
Case Else
Call sx_MovFil(sPthSrc, sDir, sPthTgt) ' .. & move them to another disk
sDir = Dir
End Select
Loop
Stop
End Sub
Private Sub sx_CrtFil(pNmb As Byte, pPth$, pNam$, pExt$)
Dim iFilNmb%
Dim sFilNam$
sFilNam = pPth & pNam & CStr(pNmb) & pExt
iFilNmb = FreeFile
Open sFilNam For Output As #iFilNmb
Close #iFilNmb
End Sub
Private Sub sx_MovFil(pPnmSrc$, pFnm$, pPthTgt$)
Dim sSrcPne$
sSrcPne = pPnmSrc & pFnm
'Debug.Print "Move " & sSrcPne & " --> " & pPthTgt
Call FileCopy(sSrcPne, pPthTgt & pFnm)
Call Kill(sSrcPne)
End Sub
'
I am having a frustrating time trying to do create a backup script in VBA. I get an error 'File not found' when trying to kill a file after opening it, making a backup and saving it under a new name.
Application.Workbooks.Open Old
ActiveWorkbook.SaveAs Archive
ActiveWorkbook.SaveAs New
'If Len(Dir$(Old)) > 0 Then Kill Old
If Len(Dir$(Old)) = 0 Then MsgBox ("bleuh")
'Here is where I get the message "Bleuh" even though Old was just opened a few lines ago..
The first line works fine, but when I want to kill the file 'Old', I get the error. Hence, I tried to test whether the file existed. The result was the Msg "Bleuh". So the file can be opened, but not found a few lines later. Can anyone explain this and help me?
In order to be complete, the entire code is found down here.
Sub UpdateAll()
Dim Afk As String, J As String, NJ As String, Path As String, strFile As String, Old As String, Archive As String, New As String
'Dim fso As Object
Path = "C:\Users\Name\OneDrive - Company\Desktop\Testing backup" & "\"
Year = Year(Date)
VJ = Year
NJ = Year + 1
Application.ScreenUpdating = False
'test for Afk (I define Afk for some additional functions that are not relevant for this problem)
Afk = "ABA"
'filenames
Old = Path & ("Planning ") & VJ & Space(1) & Afk
Archive = Path & ("Planning\Archive ") & VJ & Space(1) & Afk
New = Path & ("Planning ") & NJ & Space(1) & Afk
Application.Workbooks.Open Old
ActiveWorkbook.SaveAs Archive
ActiveWorkbook.SaveAs New
If Len(Dir$(Oud)) > 0 Then Kill Old
If Len(Dir$(Oud)) = 0 Then MsgBox ("bleuh")
'Here is where I get the message "Bleuh" even though Old was just opened a few lines ago..
'Also tried
'fso.CopyFile Old, Archive 'AND
'FileCopy Old, Archive
'in combination with:
'Name Old As New
' "SSDD"
'Next
Application.ScreenUpdating = True
End Sub
After analyzing your code I realized you don't need to open your file ('cause you don't get any information from it). You just want to move it. So, try the following:
Name Old as Archive
This should do the trick...
I'm trying to make a login/register system.
This is the registration UserForm.
Private Sub regReg_Click()
Dim TextFile As Integer
Dim FilePath As String
If regAParole.Text = "aparole" Then
FilePath = ThisWorkbook.Path & "\accounts.txt"
TextFile = FreeFile
Open FilePath For Append As #1
Print #TextFile, regID; regAmats; regParole
Close TextFile
MsgBox ("Registracija veiksmiga.")
Unload Registracija
Else
MsgBox ("Nepareiza administratora parole.")
End If
End Sub
The "aparole" thing is basically just a keyword to enter in a field so only administrators can create new accounts.
accounts.txt content looks like:
1DirectorPassword (ID+jobposition+password)
This is the authentication:
Private Sub logAuth_Click()
Dim TextFile As Integer
Dim FilePath As String
Dim FileContent As String
Dim find As String
Dim result As Integer
find = logID & logAmats & logParole
FilePath = ThisWorkbook.Path & "\accounts.txt"
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
result = InStr(FileContent, find)
If result >= 1 Then
MsgBox ("Autorizacija veiksmiga!") ' Success
Unload Autorizacija
End If
Basically when logging in I search within the accounts.txt for the string combo (ID+jobposition+password) which I use when registering. So in general the approach works, but:
If I enter everything perfectly matched = works great
If I enter the password half of it, like in a format of = 1DirectorPass it still works, so basically how can I tell to only search for the whole string and not parts of it?
I think the issue lies within InStr...
You could test for the newline markers in your file content, like this:
result = InStr(vbCrLf & FileContent, vbCrLf & find & vbCrLf)
This will only match complete lines. An extra newline is added before the file content so also the first line can be matched. At the end of the file content you would already have a vbCrLf character, because Print is supposed to add that.
I am running MS Access 2010. Using VBA I am trying to pull attachments out of MS Exchange 2013 and insert them into the Access table "TBL_APPT_ATTACHMENT".
The table "TBL_APPT_ATTACHMENT" looks like this:
Attachment_title Memo
Attachment_filename Memo
Attachment_blob OLE Object
Everything seems to work correctly except I can not figure out how to save the actual file into the column ATTACHMENT_BLOB. Here is my VBA function that I am calling (See question marks below).
Private Function createRecord(fItem As Outlook.AppointmentItem)
Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
rsAtt.OpenRecordset
For Each Attachment In fItem.Attachments
Call MsgBox("FileName: " & Attachment.FileName, vbOKOnly, "Error")
Call MsgBox("DisplayName: " & Attachment.DisplayName, vbOKOnly, "Error")
Call MsgBox("Index: " & Attachment.Index, vbOKOnly, "Error")
rsAtt.AddNew
rsAtt!APPT_ITEM_ID = aID
rsAtt!APPT_FIELD_id = rsOl!ID
rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
rsAttID = rsAtt!ID
rsAtt.Update
'Save file to harddrive.
filePath = "c:\temp\" + Attachment.FileName
Attachment.SaveAsFile (filePath)
Set rsParent = CurrentDb.OpenRecordset("SELECT ID, ATTACHMENT_BLOB FROM TBL_APPT_ATTACHMENT WHERE ID = " & rsAttID)
rsParent.OpenRecordset
Do While Not rsParent.EOF
rsParent.Edit
'Load file into Database.
'??? This next statement gives me a "Type Mismatch" error. Why?????
Set rsChild = rsParent.Fields("ATTACHMENT_BLOB").Value
rsChild.AddNew
rsChild.Fields("FileData").LoadFromFile (filePath)
rsChild.Update
rsParent.Update
rsParent.MoveNext
Loop
Next
End Function
Thanks!!
Remember that the attachment is really a file (whether its an OLE object or not). While it may be possible to perform a copy-paste of the object from Outlook into Access, my recommendation is to save the attachment as a file:
dim filepath as String
dim filename as String
filepath = "C:\appropriatefolder\"
filename = Attachment.FileName
Attachment.SaveAsFile filepath & filename
Now you're in a position to save the attachment in Access, but I seriously don't recommend using the Attachment field type. It can be rather tricky to use. So my solution to the same problem was to create a field of type Hyperlink. Then your statement in your macro will simply be:
rsAtt!ATTACHMENT_LINK = filename & "#" & filepath & filename
The hyperlink definition is important and uses the format:
displayString # fullPathToFile [ # optionalPositionInsideFile ]
EDIT: Using the Attachment Field Type in Access
The Attachment field type in an Access table can be understood if you consider it an embedded recordset within that single record. Therefore, every time you add a new record (or read an existing record), you have to handle the Attachment field a bit differently. In fact, the .Value of the Attachment field is the recordset itself.
Option Compare Database
Option Explicit
Sub test()
AddAttachment "C:\Temp\DepTree.txt"
End Sub
Sub AddAttachment(filename As String)
Dim tblAppointments As DAO.Recordset
Dim attachmentField As DAO.Recordset
Dim tblField As Field
Set tblAppointments = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT", dbOpenDynaset)
tblAppointments.AddNew
tblAppointments![APPT_ITEM_ID] = "new item id"
tblAppointments![APPT_FIELD_ID] = "new field id"
tblAppointments![ATTACHMENT_TITLE] = "new attachment"
tblAppointments![ATTACHMENT_FILENAME] = filename
'--- the attachment field itself is a recordset, because you can add multiple
' attachments to this single record. so connect to the recordset using the
' .Value of the parent record field, then use it like a recordset
Set attachmentField = tblAppointments![ATTACHMENT_BLOB].Value
attachmentField.AddNew
attachmentField.Fields("FileData").LoadFromFile filename
attachmentField.Update
tblAppointments.Update
tblAppointments.Close
Set tblAppointments = Nothing
End Sub
Here is what I ended up doing.
Private Function createRecord(fItem As Outlook.AppointmentItem)
Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
rsAtt.OpenRecordset
For Each Attachment In fItem.Attachments
'Save file to harddrive.
filePath = "c:\temp\" + Attachment.FileName
Attachment.SaveAsFile (filePath)
rsAtt.AddNew
rsAtt!APPT_ITEM_ID = aID
rsAtt!APPT_FIELD_id = rsOl!ID
rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
Call FileToBlob(filePath, rsAtt!ATTACHMENT_BLOB)
rsAttID = rsAtt!ID
rsAtt.Update
Next
End Function
Public Function FileToBlob(strFile As String, ByRef Field As Object)
On Error GoTo FileToBlobError
If Len(Dir(strFile)) > 0 Then
Dim nFileNum As Integer
Dim byteData() As Byte
nFileNum = FreeFile()
Open strFile For Binary Access Read As nFileNum
If LOF(nFileNum) > 0 Then
ReDim byteData(1 To LOF(nFileNum))
Get #nFileNum, , byteData
Field = byteData
End If
Else
MsgBox "Error: File not found", vbCritical, _
"Error reading file in FileToBlob"
End If
FileToBlobExit:
If nFileNum > 0 Then Close nFileNum
Exit Function
FileToBlobError:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
"Error reading file in FileToBlob"
Resume FileToBlobExit
End Function
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 8 years ago.
Improve this question
I’d like to remove a node from my xml file using VBA in MS Project 2007.
Should be so easy but I can’t get it running.
Here is my XML
<config id="config" ConfigSaveDate="2011-03-31 21:32:55" ConfigSchemaVersion="1.02">
<Custom>
</Custom>
<Program>
<DateFormat>yyyy-mm-dd hh:mm:ss</DateFormat>
</Program>
<ProjectFile ProjectFileName="projectfile1.mpp">
<RevisionNumber>201</RevisionNumber>
<FileName>projectfile1.mpp</FileName>
<LastSaveDate>2011-03-23 16:45:19</LastSaveDate>
</ProjectFile>
<ProjectFile ProjectFileName="projectfile2bedeleted.mpp">
<RevisionNumber>115</RevisionNumber>
<FileName>projectfile2bedeleted.mpp</FileName>
<LastSaveDate>2011-03-31 21:12:55</LastSaveDate>
</ProjectFile>
<ProjectFile ProjectFileName="projectfile2.mpp">
<RevisionNumber>315</RevisionNumber>
<FileName>projectfile2.mpp</FileName>
<LastSaveDate>2011-03-31 21:32:55</LastSaveDate>
</ProjectFile>
</config>
Here is my VBA code
Function configProjListDelete(configPath As String, ProjFiles As Variant) As Integer
' This function shall delete <ProjectFile> tags from the config.xml
' and shall delete coresponding project xml files from HD
' It shall return number of deleted files
' configPath is the path to the xml folder
' ProjFiles is an array of file names of to be deleted files in above mentioned folder
Dim xml As MSXML2.DOMDocument
Dim RootElem As MSXML2.IXMLDOMElement
'Dim cxp1 As CustomXMLPart
Dim delNode As MSXML2.IXMLDOMNode ' XmlNode 'MSXML2.IXMLDOMElement
Dim fSuccess As Boolean
Dim ProjectFileList As MSXML2.IXMLDOMElement
Dim fn As Variant 'file name in loop
Dim i As Integer
Dim delCnt As Integer
If Not FileExists(configPath) Then
' given configFile doesn't exist return nothing
Debug.Print " iven config file doesn't exist. File: " & configPath
GoTo ExitconfigProjListDelete
End If
'TODO: Catch empty ProjectFiles
' Initialize variables
Set xml = New MSXML2.DOMDocument
On Error GoTo HandleErr
' Load the XML from disk, without validating it.
' Wait for the load to finish before proceeding.
xml.async = False
xml.validateOnParse = False
fSuccess = xml.Load(configPath)
On Error GoTo 0
' If anything went wrong, quit now.
If Not fSuccess Then
GoTo ExitconfigProjListDelete
End If
Set RootElem = xml.DocumentElement
Debug.Print "- " & xml.getElementsByTagName("ProjectFile").Length & " ProjectFiles in config."
i = 0
delCnt = 0
' Loop through all ProjectFiles
For Each ProjectFileList In xml.getElementsByTagName("ProjectFile")
' check if each project file name is one of the files to be deleted
For Each fn In ProjFiles
If fn = ProjectFileList.getElementsByTagName("FileName").NextNode.nodeTypedValue Then
Debug.Print fn & " shall be deleted"
' remove it from the document
' here I'm struggeling!
'#################################################
' How to delete the node <ProjectFile> and its childNodes?
Set delNode = ProjectFileList.ParentNode
xml.DocumentElement.RemoveChild (ProjectFileList) ' Error: 438 rough translation: "Object doesn't support this methode"
' This is all I've tried, but nothing works
'===========================================
'RootElem.RemoveChild (delNode)
'xml.RemoveChild (delNode)
'RootElem.RemoveChild (ProjectFileList.SelectSingleNode("ProjectFile"))
'ProjectFileList.ParentNode.RemoveChild (ProjectFileList.ChildNodes(0))
'Set objParent = datenode.ParentNode
'xmldoc.DocumentElement.RemoveChild (objParent)
'Set ProjectFileList = Empty
delCnt = delCnt + 1
End If
Next fn
i = i + 1
Next ProjectFileList
' Save XML File
If checkAppPath("Trying to update config file.") Then
xml.Save CustomProperty("XMTMLMonitoring_AppPath") & "\" & m2w_config("SubFolder") & "\" & m2w_config("SubFolderData") & "\" & m2w_config("XMLConfigFileName")
Debug.Print " - Config has been updated and saved."
Else
MsgBox "Config data not exported to web." & Chr(10) & "Folder: '" & CustomProperty("XMTMLMonitoring_AppPath") & "\" & m2w_config("SubFolder") & "\" & m2w_config("SubFolderData") & Chr(10) & "doesn't exist. ", vbOKOnly, HEADLINE
End If
Set xml = Nothing
configProjListDelete = delCnt
ExitconfigProjListDelete:
Exit Function
HandleErr:
Debug.Print "XML File reading error " & Err.Number & ": " & Err.DESCRIPTION
MsgBox "Error " & Err.Number & ": " & Err.DESCRIPTION
On Error GoTo 0
End Function
I’d be glad to get some help!
Do you know about XPath? From the painful looks of your code, you do not. Instead of using a long combination of barbaric DOM methods to access the node you need, you should save yourself a lot of pain and just use an XPath to access it in one line.
If I understand correctly what you're trying to do, then something like the following can replace your entire double loop, from i=0 to Next ProjectFileList:
For i = LBound(ProjFiles) To UBound(ProjFiles)
Set deleteMe = XML.selectSingleNode( _
"/config/ProjectFile[#ProjectFileName='" & ProjFiles(i) & "']")
Set oldChild = deleteMe.parentNode.removeChild(deleteMe)
Next i
where the thing in "quotes" is an XPath. Hope this helps.
As a side note, it seems inefficient, confusing, and error-prone to have a ProjectFileName attribute and a FileName element containing the exact same information in your XML file. What's up with that?