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!
Related
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
Whenever i am trying to debug or run the program and if it encounters error, the VBE (Autocad) doesn't display the line where the error is, unlike in other IDEs, it used to come at that line and highlight with yellow color. Also, the scroll doesn't work. I know i should install plugins but i am unable to help myself.
Option Explicit
Sub Test()
'Declarations
'Opened Document
Dim acDocu As AcadDocument
Set acDocu = ThisDrawing.Application.ActiveDocument
'Select on screen
Dim acSelectionSet As AcadSelectionSet
Set acSelectionSet = ThisDrawing.SelectionSets.Add("SjjEffffT")
acSelectionSet.SelectOnScreen
'Manipulating in loops for finding group names having objects selected
Dim entity As AcadEntity
Dim entityhandle() As String
Dim Grp As AcadGroup
Dim groupname() As String
Dim i As Integer
i = 0
Dim j As Integer
j = 0
Dim temp As Integer
temp = 0
Dim GrpEnt As AcadEntity
Dim grpenthandle As String
Dim entity_count As Integer
'Dim entity_array As Variant
entity_count = acSelectionSet.Count
ReDim entityhandle(entity_count)
ReDim groupname(entity_count)
For Each entity In acSelectionSet
'entity_array = entity
entityhandle(i) = entity.Handle
For Each Grp In ThisDrawing.groups
For Each GrpEnt In Grp
grpenthandle = GrpEnt.Handle
If entityhandle(i) = grpenthandle Then
If temp = 0 Then
groupname(j) = Grp.Name
Debug.Print "Group in selection:" & groupname(j)
j = j + 1
End If
End If
temp = temp + 1
Next
temp = 0
Next
i = i + 1
Next
'Copying the objects and pasting into new drawing
Dim acDocto As AcadDocument
Dim file_name As String
'file_name = InputBox("Enter the file name along with full path and extension")
file_name = "D:\PI_Tool_files_3223\D00440023new.DWG"
Set acDocto = Documents.Open(file_name)
Dim acObject As AcadObject
Dim retvalue As Variant
retvalue = acDocu.CopyObjects(entityhandle, acDocto.ModelSpace)
acSelectionSet.Delete
End Sub
The code is written above. But i think the problem is with the add-in as i can't debug.
The VBA IDE is pretty old (1998) and it has limited debugging abilities. You should stop using this, it's an obsolete technology, not actively supported by Microsoft/Autodesk anymore.
For some errors, it is not able to locate the line where the error occurred, and you're left with obscure error codes and useless messages.
Have you tried setting a breakpoint at the first possible line? (Set acDocu = ThisDrawing.Application.ActiveDocument)
Then step through to see the offending object/property/method.
It doesn't always work.
Can you load the code into a module, instead of "ThisDrawing", then debug?
My application currently extracts data from an excel document, putting the data into a listview. I then am able to open each of the strings/items within the listview (which are pdf files in a given directory). However the pdf files within the given directory have revision letters at the end of their file names, starting with 'A' for the first revision and 'B' for the second revision...and so on.
So I am trying to approach it like comparing the string to the files in the directory and then once it's found, check what the latest rev letter is if any.
So if there is 07010302A.pdf file in the directory and there's also a 07010302B.pdf in the directory, I want to store that file name (07010302B.pdf) to a new string in my vb application. Any help on this would be much appreciated.
Here's what I am working with:
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim xlApp As Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim range As Excel.Range
Dim rCnt As Integer
Dim cCnt As Integer
Dim Obj As Object
xlApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Open("C:\Users\Admin\Desktop\Exp_Master.xlsm")
xlWorkSheet = xlWorkBook.Worksheets("Sheet1")
range = xlWorkSheet.Range("H1:H100") 'xlWorkSheet.UsedRange
For rCnt = 1 To range.Rows.Count
For cCnt = 1 To range.Columns.Count
Obj = CType(range.Cells(rCnt, cCnt), Excel.Range)
If IsNumeric(CType(range.Cells(rCnt, cCnt), Excel.Range).Value) Then
'MsgBox(Obj.value)
ListView1.Items.Add(Obj.value)
ListView1.View = View.List
End If
Next
Next
xlWorkBook.Close()
xlApp.Quit()
releaseObject(xlApp)
releaseObject(xlWorkBook)
releaseObject(xlWorkSheet)
'Kill Excel Process that wouldn't close
Process.Start("C:\Users\Admin\Desktop\batch archive\EXCEL_KILLER.bat")
'MsgBox("Total Item(s) in ListView:" & ListView1.Items.Count)
Dim i As Integer = 0
Dim n As Integer = 0
Dim str As String
For i = 1 To (ListView1.Items.Count)
Dim strng As String = "R:\"
n = (i - 1)
str = strng & (ListView1.Items.Item(n).Text) & (".pdf")
MsgBox(str)
'----
'System.Diagnostics.Process.Start(str)
'Here I want to check the R:\ directory and compare it with each string to see
'what the latest revision letter of the filename is and store it in another string to add to
'a pdf merging list later in this for loop
'----
Next
End Sub
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
I was able to use your Directory.getfiles suggestion and I added a for loop to display only the last of the files labeled within that criteria. Thanks a bunch, just took a little more playing with it to determine what I actually wanted and how to put it in code.
If anyone cares, here is the update that works and gets the last file name and path of the directory.getfiles group within a search criteria.
Cheers!
For i = 1 To (ListView1.Items.Count)
Dim strng As String = "R:\"
n = (i - 1)
str = strng & (ListView1.Items.Item(n).Text) & (".pdf")
'MsgBox(str)
Dim substr As String
substr = str.Substring(3, 8)
'MsgBox(substr)
'----
'System.Diagnostics.Process.Start(str)
' Only get files that begin with...
Dim dirs As String() = Directory.GetFiles("R:\", (substr & ("*.pdf")))
'MsgBox("The number of files starting with your string is {0}.", dirs.Length)
Dim dir As String
For Each dir In dirs
If dir Is dirs.Last Then
MsgBox(dir)
'do something with your last item'
End If
Next
'----
Next
End Sub
i'm trying to importe a csv file after creating on the same application, the only probleme is that even if a string matchs a line from the file, comparing them on vb.net dosn't give a true boolean i know i didn't make any mistakes because of the line with the commentary 'THIS LINE , i use a pretty small list to do my test and in that loop, there is always one element that matches exactly the string, but comparing them on vb.net dosn't return a true. the result of this is that just after saving the file to my computer while still having it on my listview1 on the application, i load it to the application again and it duplicates everything
Dim open As New OpenFileDialog
open.Filter = "CSV Files (*.csv*)|*.csv"
If open.ShowDialog = Windows.Forms.DialogResult.OK Then
Dim File As String = My.Computer.FileSystem.ReadAllText(open.FileName)
Dim lines() As String = File.Split(Environment.NewLine)
For i = 1 To (lines.Count - 1)
Dim line As String = lines(i)
Dim Columns() As String = line.Split(";")
Dim addLin As New ListViewItem(Columns)
Dim Alr As Boolean = False
Dim st as string=listView1.Items.Item(k).SubItems.Item(0).Text
For k = 0 To (ListView1.Items.Count - 1)
Dim st as string=listView1.Items.Item(k).SubItems.Item(0).Text
MsgBox(Columns(0)& Environment.NewLine & st) 'THIS LINE
If ListView1.Items.Item(k).SubItems.Item(0).Text = Columns(0) Then
Alr = True
MsgBox("true") 'never showsup even when the previous one show the match
End If
next
If Alr = False Then
MsgBox("false") 'the msgbox is only to check
ListView1.Items.Add(addLin)
End If
next
end if
I'm currently using the following to read the contents of all text files in a directory into an array
Dim allLines() As String = File.ReadAllLines(txtfi.FullName)
Within the text files are only 6 lines that all follow the same format and will read something like
forecolour=black
I'm trying to then search for the word "forecolour" and retrieve the information after the "=" sign (black) so i can then populate the below code
AllDetail(numfiles).uPath = ' this needs to be the above result
I've only posted parts of the code but if it helps i can post the rest. I just need a little guidance if possible
Thanks
This is the full code
Dim numfiles As Integer
ReDim AllDetail(0 To 0)
numfiles = 0
lb1.Items.Clear()
Dim lynxin As New IO.DirectoryInfo(zMailbox)
lb1.Items.Clear()
For Each txtfi In lynxin.GetFiles("*.txt")
Dim allLines() As String = File.ReadAllLines(txtfi.FullName)
ReDim Preserve AllDetail(0 To numfiles)
AllDetail(numfiles).uPath = 'Needs to be populated
AllDetail(numfiles).uName = 'Needs to be populated
AllDetail(numfiles).uCode = 'Needs to be populated
AllDetail(numfiles).uOps = 'Needs to be populated
lb1.Items.Add(IO.Path.GetFileNameWithoutExtension(txtfi.Name))
numfiles = numfiles + 1
Next
End Sub
AllDetail(numfiles).uPath = Would be the actual file path
AllDetail(numfiles).uName = Would be the detail after “unitname=”
AllDetail(numfiles).uCode = Would be the detail after “unitcode=”
AllDetail(numfiles).uOps = Would be the detail after “operation=”
Within the text files that are being read there will be the following lines
Unitname=
Unitcode=
Operation=
Requirements=
Dateplanned=
For the purpose of this array I just need the unitname, unitcode & operation. Going forward I will need the dateplanned as when this is working I want to try and work out how to only display the information if the dateplanned matches the date from a datepicker. Hope that helps and any guidance or tips are gratefully received
If your file is not very big you could simply
Dim allLines() As String = File.ReadAllLines(txtfi.FullName)
For each line in allLines
Dim parts = line.Split("="c)
if parts.Length = 2 andalso parts(0) = "unitname" Then
AllDetails(numFiles).uName = parts(1)
Exit For
End If
Next
If you are absolutely sure of the format of your input file, you could also use Linq to remove the explict for each
Dim line = allLines.Where(Function(x) (x.StartsWith("unitname"))).SingleOrDefault()
if line IsNot Nothing then
AllDetails(numFiles).uName = line.Split("="c)(1)
End If
EDIT
Looking at the last details added to your question I think you could rewrite your code in this way, but still a critical piece of info is missing.
What kind of object is supposed to be stored in the array AllDetails?
I suppose you have a class named FileDetail as this
Public class FileDetail
Public Dim uName As String
Public Dim uCode As String
Public Dim uCode As String
End Class
....
numfiles = 0
lb1.Items.Clear()
Dim lynxin As New IO.DirectoryInfo(zMailbox)
' Get the FileInfo array here and dimension the array for the size required
Dim allfiles = lynxin.GetFiles("*.txt")
' The array should contains elements of a class that have the appropriate properties
Dim AllDetails(allfiles.Count) as FileDetail
lb1.Items.Clear()
For Each txtfi In allfiles)
Dim allLines() As String = File.ReadAllLines(txtfi.FullName)
AllDetails(numFiles) = new FileDetail()
AllDetails(numFiles).uPath = txtfi.FullName
Dim line = allLines.Where(Function(x) (x.StartsWith("unitname="))).SingleOrDefault()
if line IsNot Nothing then
AllDetails(numFiles).uName = line.Split("="c)(1)
End If
line = allLines.Where(Function(x) (x.StartsWith("unitcode="))).SingleOrDefault()
if line IsNot Nothing then
AllDetails(numFiles).uName = line.Split("="c)(1)
End If
line = allLines.Where(Function(x) (x.StartsWith("operation="))).SingleOrDefault()
if line IsNot Nothing then
AllDetails(numFiles).uOps = line.Split("="c)(1)
End If
lb1.Items.Add(IO.Path.GetFileNameWithoutExtension(txtfi.Name))
numfiles = numfiles + 1
Next
Keep in mind that this code could be really simplified if you start using a List(Of FileDetails)