How to read binary content of an embeded word object - vba

I have an embedded OLE object in word as "InlineShape". I would like to access this object as a data stream / string. at the moment, I can see some ideas for Excel via OLEObject, but it seems that there is no solution for Word that I can see.

The following code achieves what I want:
' from here: https://stackoverflow.com/questions/1356118/vba-ws-toolkit-how-to-get-current-file-as-byte-array
Public Function GetFileBytes(ByVal path As String) As Byte()
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
lngFileNum = FreeFile
If LenB(Dir(path)) Then ''// Does file exist?
Open path For Binary Access Read As lngFileNum
ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
Get lngFileNum, , bytRtnVal
Close lngFileNum
Else
Err.Raise 53
End If
GetFileBytes = bytRtnVal
Erase bytRtnVal
End Function
Sub TestMe()
Dim shapeIndex As Integer: shapeIndex = 1
Dim ns As Object
Dim folderItem
Const namePrefix = "site-visit-v2.5"
Const nameSuffix = ".dat"
Dim fileBytes() As Byte
Dim tempDir As String: tempDir = Environ("TEMP")
' first embedded Item - you may need adjust if you have more shapes
ActiveDocument.InlineShapes.Item(shapeIndex).Range.Copy
' paste it to temp dir
Set ns = CreateObject("Shell.Application").namespace((tempDir))
ns.Self.InvokeVerb ("Paste")
' find the file now
Dim Item As Object
Dim rightItem As Object
Set rightItem = Nothing
' find the file that was pasted
' because when files are pasted and name exists, you could get a name such as "site-visit-v2.5 (10).dat"
' we pick the most recent that matches
For Each Item In ns.Items
If Item.Name Like namePrefix & "*" & nameSuffix Then
If rightItem Is Nothing Then
Set rightItem = Item
Else
If Item.modifyDate > rightItem.modifyDate Then 'a more recent date is found
Set rightItem = Item
End If
End If
End If
Next
fileBytes = GetFileBytes(tempDir & "\" & rightItem.Name)
MsgBox "Read " & UBound(fileBytes) + 1 & " bytes"
End Sub

Related

VBA Document.Path returns Web path when in OneDrive - Need local path

I am trying to get the local file path to an open document.
When I use the Path function I get a web path if the document is in my OneDrive folder.
I think the problem is that the file exists in 2 places:
C:\Users\myloginname\OneDrive\Documents\Project\Samples
AND
https://d.docs.live.net/xxxxxxxxxxxx/Documents/Project/Samples
When I try to use the Dir function with the web "path" I get error 52 "Bad file name or number".
How can I get the local path?
The function below will return the local name of a FullName given to it as argument.
Function LocalFullName(ByVal Ffn As String) As String
' 294
' this is part of the URL address before the file's code name
' e.g. https://d.docs.live.net/2abce27df5c02e2f/ ....
Const DriveID As String = ".live.net"
Dim Fun() As String ' function return value
Dim n As Integer ' index of Fun
Dim Sp() As String ' split array of Ffn
Dim i As Integer ' loop counter: index of Sp
Sp = Split(Ffn, "/")
For i = 1 To UBound(Sp)
If InStr(1, Sp(i), DriveID, vbTextCompare) Then Exit For
Next i
If i > UBound(Sp) Then
LocalFullName = Ffn
Else
ReDim Fun(1 To UBound(Sp))
For i = i + 2 To UBound(Sp)
n = n + 1
Fun(n) = Sp(i)
Next i
ReDim Preserve Fun(1 To n)
LocalFullName = Join(Fun, Application.PathSeparator)
End If
End Function
If you need to use the name for saving the drive must be added. The snipper below shows how to call the function and add the drive letter.
Sub Snippet()
' 294
Const DriveID As String = "D:\"
Dim Wb As Workbook
Set Wb = ThisWorkbook
Debug.Print DriveID & LocalFullName(Wb.FullName)
End Sub
I ended up using this as I only wanted the folder path.
Also, it's kind of a choose-your-poison when using hard-coded text, but I worry that ".live.net" might change. Of course, so could "\OneDrive\" so there ya go.
Private Function Local_Workbook_Path(ByRef doc As Document) As String
Dim Ctr As Long
Dim objShell As Object
Dim UserProfilePath As String
'Check if it looks like a OneDrive location
If InStr(1, doc.path, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
Local_Workbook_Path = Replace(doc.path, "/", "\")
'Get environment path using vbscript
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
'Trim OneDrive designators
For Ctr = 1 To 4
Local_Workbook_Path = Mid(Local_Workbook_Path, InStr(Local_Workbook_Path, "\") + 1)
Next
'Construct the name
Local_Workbook_Path = UserProfilePath & "\OneDrive\" & Local_Workbook_Path
Local_Workbook_Path = Replace(Local_Workbook_Path, "%20", " ")
Else
Local_Workbook_Path = doc.path
End If
End Function

Saving all parts in an assembly as STEP with custom properties. How to solve run-time error 91?

I'm trying to write a macro with VBA in Solidworks that will go through all the sub assemblies and save every part as STEP-file where the name is determined by a custom property. I don't have a lot of programming experience as I'm an mechanical engineer but I try to automate some processes from time to time. Most of this code I got from others and I tried to tweak it to my situation. I do understand most of what is happening though.
The problem I'm having is that I keep getting a
91 runtime error
When I go to debugging Solidworks tells me the problem is in the line name = swPart.GetTitle. At first it said "name = nothing". I tried looking for the problem and when i added Set swApp = Application.SldWorks to the sub I still got the error but now name is always something.
Dim swApp As SldWorks.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim retVal As Boolean
Dim errors As Long, warnings As Long
Dim revision As String
Dim vaultPath As String
Dim name As String
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swAssy = swApp.ActiveDoc
Set swConf = swAssy.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent3(True)
vaultPath = "C:\Users\Engineering\Desktop\test\" 'set folder for vault (change this later)
TraverseComponent swRootComp, 1, vaultPath
End Sub
Sub TraverseComponent(swComp As SldWorks.Component2, nLevel As Long, vaultPath As String)
Dim vChilds As Variant, vChild As Variant
Dim swChildComp As SldWorks.Component2
Dim MyString As String
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Set swApp = Application.SldWorks
vChilds = swComp.GetChildren
For Each vChild In vChilds
Set swChildComp = vChild
Dim FileName As String
FileName = swChildComp.GetPathName
FileName = Left(FileName, InStr(FileName, ".") - 1)
FileName = Right(FileName, Len(FileName) - InStrRev(FileName, "\"))
Debug.Print "Part Name : " & FileName
MyString = FileName
Dim ActiveConfig As String
ActiveConfig = swChildComp.ReferencedConfiguration
Debug.Print "Configuration: " & ActiveConfig
FileName = swChildComp.GetPathName
If UCase(Right(FileName, 6)) = "SLDPRT" Then
'MsgBox ("part found")
Dim swPart As SldWorks.ModelDoc2
Set swPart = swApp.OpenDoc6(swChildComp.GetPathName, 1, 0, "", longstatus, longwarnings)
'Dim name As String 'I tried adding this but it made no difference
name = swPart.GetTitle 'get the title of the active document
'chop the extension off if present
If Right(name, 7) = ".SLDPRT" Or Right(name, 7) = ".SLDasm" Then
name = Left(name, Len(name) - 7)
End If
Set swCustPropMgr = swPart.Extension.CustomPropertyManager("") 'get properties
revision = swCustPropMgr.Get("Revision") 'get revision
retVal = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swStepAP, 214) 'change the step file options
'save with revision if present
If revision = "" Or revision = Null Then
retVal = swPart.Extension.SaveAs(vaultPath & name & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
Else
retVal = swPart.Extension.SaveAs(vaultPath & name & " - Rev " & revision & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
End If
swApp.CloseDoc swPart.GetTitle
End If
Debug.Print
TraverseComponent swChildComp, nLevel + 1, vaultPath
Next
End Sub
A suppressed component is not the only reason why you could get a "nothing" after calling OpenDoc. This happens e.g. if the component is loaded lightweight or is otherwise not fully loaded. Then you are also not able to get the ModelDoc (PartDoc) data of a component object.
To prevent this completely you could execute the next lines only if the swPart variable is not nothing.
If (Not swPart Is Nothing) Then
name = swPart.GetTitle 'get the title of the active document
...
End If
Additionally I can say you don't necessarily need to use OpenDoc/CloseDoc because the component is already loaded into memory when the assembly is loaded. Therefore it is enough to call GetModelDoc2 of the child component. But in the end it has the same behaviour and will return nothing if the component is not fully loaded.
set swPart = swChildcomp.GetModelDoc2()

Combine 2 pdfs in one using VBA

I'm currently working on a macro that creates a PDF from a SolidWorks file and then, if the Solidworks File is an assembly, it would merge the pdf with its BOM.
The problem is that I've coded the merge part of the macro, but I keep getting a "False" result on the merge line of my code and I can't find why...
Once it will be debugged, this will become a Function that will get 2 file paths to merge.
Can you help me make the macro actually merge the two files? I can't find anything about why it can return a false results.
So thank you for your help!
Here's my actual code:
Sub CombinePDFs() '(ByVal NewAsmPdf As String, ByVal OldAsmPdf As String)
' The function will combine the PDFs keeping the BOM of the older file merged (The one which is replaced)
Dim Adobe As AcroPDDoc
Dim PDF1 As Object
Dim PDF2 As Object
Dim PageNF As Long
Dim PageOF As Long
Dim b As Byte
Dim NewAsmPdf As String
Dim OldAsmPdf As String
NewAsmPdf = "Path.PDF"
OldAsmPdf = "Path_BOM.PDF"
' Defines the two PDFs to be merged
Set PDF1 = CreateObject("AcroExch.PDDoc")
PDF1.Open (NewAsmPdf)
Set PDF2 = CreateObject("AcroExch.PDDoc")
PDF2.Open (OldAsmPdf)
'Get the pages to be keep
PageNF = PDF1.GetNumPages
PageOF = PDF2.GetNumPages - PageNF
'Insert PDF2 BOM in PDF1
If PDF1.InsertPages(PageNF, PDF2, PageNF + 1, PageOF, 0) Then 'Here is my problem : Keep having false (No merge)
Kill (OldAsmPdf)
Else
MsgBox ("Could not merge the Old and New file")
End If
End Sub
SOLVED!
I found out that VBA counts from 0 (So page 1 is actually the page 0) so the false was returned due to impossible values in attributes.
Here's the code of the function that I've done:
Function CombinePDFs(ByVal NewAsmPdf As String, ByVal OldAsmPdf As String)
' The function will combine the 2 PDFs and replace the OldFile by the NewFile
Dim PDF1 As Object
Dim PDF2 As Object
Dim PageNF As Long
Dim PageOF As Long
Dim NewAsmPdf As String
Dim OldAsmPdf As String
' Defines the two PDFs to be merged
Set PDF1 = CreateObject("AcroExch.PDDoc")
PDF1.Open (NewAsmPdf)
Set PDF2 = CreateObject("AcroExch.PDDoc")
PDF2.Open (OldAsmPdf)
'Get the pages to be keep
PageNF = PDF1.GetNumPages
PageOF = PDF2.GetNumPages
' Insert PDF2 BOM in PDF1
If PDF1.InsertPages(PageNF - 1, PDF2, PageNF, PageOF-1, 0)
If Not PDF1.Save(PDSaveFill, NewAsmPdf) Then
MsgBox ("Not saved")
End If
' Delete "_BOM.PDF" file
PDF2.Close
Kill (OldAsmPdf)
Else
MsgBox ("Could not merge the Old and New file")
End If
' Clear memory
Set PDF1 = Nothing
Set PDF2 = Nothing
End Function
Have fun!

How to store data from a file in memory for reuse?

I have VBA code which executes on mail's reception.
I want to forward a template to the first address found in the mail. I execute a regex to find the email address in the mail, read a html file (the template) and forward it to the email address.
Outlook shuts down after few minutes. I think it is a performance problem. I want to optimize the code and if I can between two executions not read the template two times. Is it possible to store it into a global variable?
Sub GetEmailAndForward(Item As Outlook.MailItem)
' RegExp
Dim mailRegExp As RegExp
' File
Dim FileTemplate As Integer
Dim FileProperties As Integer
' Properties
Dim splitProperty() As String
' Email
Dim DataLine As String
Dim emails As MatchCollection
Dim email As String
Dim forward As Outlook.MailItem
Dim body As String
Dim forwardText As String
' Path
Dim fileTemplatePath As String
Dim dirPath As String
Dim filePropertyPath As String
dirPath = "C:\OutlookVBA"
Set mailRegExp = New RegExp
With mailRegExp
.Pattern = "[\_]*([a-z0-9]+(\.|\_*)?)+#([a-z][a-z0-9\-]+(\.|\-*\.))+[a-z]{2,6}"
.Global = False
.IgnoreCase = True
End With
' Get the template
fileTemplatePath = dirPath & "\template.html"
' Get the email body to analyse
body = Item.body
' Get the first email found
If mailRegExp.Test(body) Then
Set emails = mailRegExp.Execute(body)
If emails.Count > 0 Then
email = emails.Item(0)
Set forward = Item.forward
FileTemplate = FreeFile()
Open fileTemplatePath For Input As #FileTemplate
While Not EOF(FileTemplate)
Line Input #FileTemplate, DataLine
forwardText = forwardText & DataLine
Wend
forward.BodyFormat = olFormatHTML
forward.HTMLBody = forwardText & forward.HTMLBody
Close #FileTemplate
If Not IsEmpty(email) Then
forward.Recipients.Add email
forward.subject = "RE:" & Item.subject
forward.Send
End If
End If
End If
End Sub
You can use something like this - the function will only read from the file on the first call, and after that will use the text stored in the static variable:
Function GetForWardText(f As String) As String
Static rv As String '<< valuje is maintained between calls
If Len(rv) = 0 Then
rv = CreateObject("scripting.filesystemobject"). _
opentextfile(f, 1).readall()
End If
ForWardText = rv
End Function
In your code, remove this:
FileTemplate = FreeFile()
Open fileTemplatePath For Input As #FileTemplate
While Not EOF(FileTemplate)
Line Input #FileTemplate, DataLine
forwardText = forwardText & DataLine
Wend
and replace with:
forwardText = GetForWardText(fileTemplatePath)

How to Copy HTML file along with all the associated images and scripts folder?

I want to copy an HTML file from one location to another using VB.net.
When i use any of the three FileCopy, System.IO.File.Copy, My.Computer.FileSystem.CopyFile
it copies only the file and not the "filename_files" folder which contain its associated images and scripts.
What i want to do programatically is copy a.html to another location as b.html
when i do that and open b.html it opens it without any images and scripts.
Pls help
You can use following two methods that collectively can copy folder that that includes scripts and images thus, with built-in method FileCopy copy your HTML file, and using below methods, copy your required folder.
I found the first method that returns an array of files in a given path at here
Public Function FileList(Mask As String) As String()
Dim sWkg As String
Dim sAns() As String
Dim lCtr As Long
ReDim sAns(0) As String
sWkg = Dir(Mask, vbNormal)
Do While Len(sWkg)
If sAns(0) = "" Then
sAns(0) = sWkg
Else
lCtr = UBound(sAns) + 1
ReDim Preserve sAns(lCtr) As String
sAns(lCtr) = sWkg
End If
sWkg = Dir
Loop
FileList = sAns
End Function
Now using the above method, and the below method, you can copy folder by specifying Source and Target paths. The method will return boolean value specifying whether folder was copied or not.
Public Function FolderCopy(ByVal SourceFolder As String, ByVal TargetFolder As String) As Boolean
Dim flist() As String
Dim sURL As String = New String(SourceFolder)
Dim tURL As String = New String(TargetFolder)
Dim i As Integer
Dim slashpos As Long
If Not Directory.Exists(tURL) Then
slashpos = InStrRev(sURL, "\") 'Get position of last occurrence if '\' in given path
If slashpos <> sURL.Length Then 'Check if URL does not have slash at its end
sURL = sURL & "\" 'Add slash at URL end
End If
flist = FileList(sURL)
slashpos = InStrRev(tURL, "\") 'Get position of last occurrence if '\' in given path
If slashpos = tURL.Length Then
tURL = tURL.Substring(0, tURL.Length - 1)
End If
slashpos = InStrRev(tURL, "\")
Try
Directory.CreateDirectory(tURL)
For i = 0 To flist.Length - 1
FileCopy(sURL & flist(i), tURL & "\" & flist(i))
Next
FolderCopy = True
Catch ex As Exception
FolderCopy = False
End Try
Else
FolderCopy = False
End If
End Function
Make sure that you include Imports System.IO at the beginning of the class before using FolderCopy method, and note that both these methods are required to be included.
' copy all files and subdirectories from the
' specified source to the specified destination.
Private Sub RecursiveCopyFiles( ByVal sourceDir As String, ByVal destDir As String, _
ByVal fRecursive As Boolean)
Dim i As Integer
Dim posSep As Integer
Dim sDir As String
Dim aDirs() As String
Dim sFile As String
Dim aFiles() As String
' Add trailing separators to the supplied paths if they don't exist.
If Not sourceDir.EndsWith(System.IO.Path.DirectorySeparatorChar.ToString()) Then
sourceDir &= System.IO.Path.DirectorySeparatorChar
End If
If Not destDir.EndsWith(System.IO.Path.DirectorySeparatorChar.ToString()) Then
destDir &= System.IO.Path.DirectorySeparatorChar
End If
' Recursive switch to continue drilling down into dir structure.
If fRecursive Then
' Get a list of directories from the current parent.
aDirs = System.IO.Directory.GetDirectories(sourceDir)
For i = 0 To aDirs.GetUpperBound(0)
' Get the position of the last separator in the current path.
posSep = aDirs(i).LastIndexOf("\")
' Get the path of the source directory.
sDir = aDirs(i).Substring((posSep + 1), aDirs(i).Length -(posSep + 1))
' Create the new directory in the destination directory.
System.IO.Directory.CreateDirectory(destDir + sDir)
' Since we are in recursive mode, copy the children also
RecursiveCopyFiles(aDirs(i), (destDir + sDir), fRecursive)
Next
End If
' Get the files from the current parent.
aFiles = System.IO.Directory.GetFiles(sourceDir)
' Copy all files.
For i = 0 To aFiles.GetUpperBound(0)
' Get the position of the trailing separator.
posSep = aFiles(i).LastIndexOf("\")
' Get the full path of the source file.
sFile = aFiles(i).Substring((posSep + 1), aFiles(i).Length - (posSep+ 1))
' Copy the file.
System.IO.File.Copy(aFiles(i), destDir + sFile)
Next i
End Sub