I have a VB.Net program that will open a .dwg and then give the user the ability to add “part blocks” to the drawing.
However, I need to be able to shift all the components in the drawing at one time.
How do I “Select All” from the API in DraftSight? The code below is what I have got started.
'Connect to DraftSight
dsApp = GetObject(, "DraftSight.Application")
'Get active document
dsDoc = dsApp.GetActiveDocument()
If Not dsDoc Is Nothing Then
'Get model space
dsModel = dsDoc.GetModel()
'Get Sketch Manager
dsSketchManager = dsModel.GetSketchManager()
'Basic Command I want to use to Move Selection
' - MOVE
' - Specify Entities = SelectALL
' - Specify Entities = "Enter"
' - Specify from Point = insertX, insertY
' - Specify destination = 0,0
'Move instance parameters
Dim Move_Instance As ISketchManager
Dim insertX As Double
insertX = 5.0
Dim insertY As Double
insertY = 10.0
Dim insertZ As Double
insertZ = 0.0
Dim SelectALL As Object
'Move Selection
Move_Instance = dsApp.GetActiveDocument().GetModel().GetSketchManager.MoveEntities(insertX, insertY, insertZ, SelectALL)
Else
MsgBox("There are no open documents in DraftSight")
End If
After some trial and error, I decide a way to do what I am looking for is to just use the “RunCommand” feature. Below is what I did…
Dim dsApp As DraftSight.Application
Dim dsDoc As DraftSight.Document
Dim dsModel As DraftSight.Model
Dim dsSketchManager As DraftSight.SketchManager
Dim dsViewManager As DraftSight.ViewManager
'Connect to DraftSight
dsApp = GetObject(, "DraftSight.Application")
'Abort any command currently running in DraftSight
'to avoid nested commands
dsApp.AbortRunningCommand()
'Get active document
dsDoc = dsApp.GetActiveDocument()
If Not dsDoc Is Nothing Then
'Get model space
dsModel = dsDoc.GetModel()
'Get Sketch Manager
dsSketchManager = dsModel.GetSketchManager()
Dim dsSheet As DraftSight.Sheet
Dim dsVarSheets As Object
dsVarSheets = dsDoc.GetSheets
dsSheet = dsVarSheets(1)
If dsSheet Is Nothing Then
Return
End If
'Get View Manager
dsViewManager = dsDoc.GetViewManager()
'Select All and Move to location 0,0
Dim Move As Integer
Move = dsApp.RunCommand("MOVE ALL -5.0,-10.0 0.0,0.0", False)
Else
MsgBox("There are no open documents in DraftSight")
End If
Related
I am using MS-Access 2007 VBA.
I am attempting to convert a pdf to an image. I found this chunk of code online, but they failed to provide all the references. My compile is failing on vbCFBitmap. Does anyone know where this reference comes from?
Dim MyAcro As New AcroApp
Dim MyPDF As New AcroPDDoc
Dim MyPage As AcroPDPage
Dim MyPt As acrobat.AcroPoint
Dim MyRect As AcroRect
Dim MyData As DataObject
Dim strPathString As String
Dim MyPath As String
Dim SaveToPath As String
Dim mysavepath As String
MyPath = "\\spfs1\stone\Long Term Share\gentex_ppaps\gentex_ppaps_raw\Supplier Request Number 3034910, Gentex Part Number 345-2120-000 Revision (003).pdf"
mysavepath = "C:\out"
' open the PDF
MyPDF.Open (MyPath)
Set MyPage = MyPDF.AcquirePage(0)
' Convert Point to Twips for document
Set MyPt = New AcroPoint
'Define the rectangle that contains the PDF form
Set MyRect = New acrobat.AcroRect
MyRect.Top = 0
MyRect.Left = 0
MyRect.Right = MyPt.x
MyRect.bottom = MyPt.y
' Copy the PDF image to the clip board
Call MyPage.CopyToClipboard(MyRect, MyRect.Left, MyRect.Top, 100)
' Capture image from clip board to data object
Set MyData = Clipboard.GetData(vbCFBitmap)
'Save the data object
SavePicture MyData, mysavepath
' Clean up
Set MyAcro = Nothing
Set MyPDF = Nothing
Set MyPage = Nothing
Set MyPt = Nothing
Set MyRect = Nothing
Set MyData = Nothing
That's likely VB6 code, not VBA.
vbCFBitmap is a system global, and thus not imported using any references.
However, that's just a copy of the Windows Standard Clipboard Formats, thus vbCFBitmap is equal to 2. You can use 2 instead.
I am trying to generate multiple Word documents which have content controls that are populated from an Excel file. The second content control needs to be populated with a list which varies in length.
How do I add each value to the content control instead of replacing the current value? I am currently using Rich Text Content Controls.
Here is what I have so far:
Sub CreateCoverLetters()
Dim objWord As Word.Application
Dim wDoc As Word.Document
Dim Rows As Integer
Set objWord = CreateObject(Class:="Word.Application")
objWord.Visible = True
Set wDoc = objWord.Documents.Open(*insert filepath*)
objWord.Activate
wDoc.ContentControls(1).Range.Text = Worksheets("Lists").Range("A2").Value
Rows = Worksheets("Lists").Range("A3", Range("A3").End(xlDown)).Rows.Count
r = 3
For i = 1 To Rows
wDoc.ContentControls(2).Range.Text = Worksheets("Lists").Cells(r, 1).Value
r = r + 1
Next
wDoc.SaveAs (*insert filepath*)
End Sub
Any help much appreciated!
Solved it as follows:
Sub CreateCoverLetters()
Dim objWord As Word.Application
Dim wDoc As Word.Document
Dim Rows As Integer
Dim Content As String
Set objWord = CreateObject(Class:="Word.Application")
objWord.Visible = True
Set wDoc = objWord.Documents.Open(*insert filepath*)
objWord.Activate
wDoc.ContentControls(1).Range.Text = Worksheets("Lists").Range("A2").Value
Rows = Worksheets("Lists").Range("A3", Range("A3").End(xlDown)).Rows.Count
r = 3
For i = 1 To Rows
Content = Content & "- " & Worksheets("Lists").Cells(r, 1).Value & vbNewLine
r = r + 1
Next
wDoc.ContentControls(2).Range.Text = Content
wDoc.SaveAs (*insert filepath*)
End Sub
The approach in user's answer works if the content can 1) be concatenated in a single string and 2) none of the elements require special formatting. This would also be the fastest approach.
If for any reason this process is not possible, then the way to "append" content without replacing goes something like in the code snippet that follows.
Notice how Range and ContentControl objects are declared and instantiated, especially the Range object. This makes it much easier to pick up the "target" at a later point in the code. Also, a Range object can be collapsed (think of it like pressing the right-arrow to make a selection a blinking cursor): this makes it possible to append content and work with that new content (format it, for example). Word also has a Range.InsertAfter method which can be used if the new content does not have to be manipulated in any special way.
Dim cc as Object ' Word.ContentControl
Dim rngCC as Object 'Word.Range
Set cc = wDoc.ContentControls(1).Range
Set rngCC = cc.Range
rngCC.Text = Worksheets("Lists").Range("A2").Value
'Add something at a later point
rngCC.Collapse wdCollapseEnd
rngCC.Text = " New material at the end of the content control."
I have a Catia part where I have a few sketches on different planes. I need to be able to convert these sketches into 3D points which I copy to a new part document.
I have tried to use the Search and Selection commands in VB script in order to use a macro to pick up all the 2D points in my sketch and convert them to 3D points but to no avail.
Sub CATMain()
Set oSel = CATIA.ActiveDocument.Selection
strArray(0)=”Part”
Msgbox “Please select parts to join.”
sStatus = oSel.SelectElement3(strArray, “Select parts”, False, CATMultiSelTriggWhenUserValidatesSelection, false)
iCount = oSel.Count
For i= 1 to iCount
Set myObject2 = oSel.Item(i).value
oSel.Search “Name=Point,sel”
ReDim copies(iCount)
For k=1 to iCount
Set copies(k)=oSel.Item(k).Value
oSel.Add copies(k)
oSel.Copy
Next ‘k
Next ‘i
Set part2 = CATIA.Documents.Add(“CATPart”)
part2.Product.PartNumber = “My New Part”
Dim GSet1 As HybridBody
Set GSet1 = part2.Part.HybridBodies.Item(1)
GSet1.Name = “My Geometry”
Set partDocument2= CATIA.ActiveDocument
Dim ActSel As Selection
Set ActSel=partDocument2.Selection
ActSel.Add GSet1
ActSel.PasteSpecial(“CATPrtResultWithOutLink” )
ActSel.Clear
End Sub
You have to disassemble the sketch to get at the points as something you can copy
The disassemble command is exposed in VB via the HybridShapeFactory.AddNewDatums method.
Option Explicit
Sub CATMain()
Dim oPart As part
Set oPart = CATIA.ActiveDocument.part
Dim oHSF As HybridShapeFactory
Set oHSF = oPart.HybridShapeFactory
Dim sx As Sketch
Set sx = oPart.HybridBodies.item("Geometrical Set.1").HybridSketches.item("Sketch.1")
'make a temporary body
Dim targetGS As HybridBody
Set targetGS = oPart.HybridBodies.add
targetGS.name = "TMP_BODY___DELETE_ME"
'create a datum curve from the sketch
Dim sxRef As Reference
Set sxRef = oPart.CreateReferenceFromObject(sx)
'make a zero-translate from the sketch
'This is required because AddNewDatums functions needs a HybridShape feature
Dim oZero As HybridShapeTranslate
Set oZero = oHSF.AddNewTranslate(sxRef, oHSF.AddNewDirectionByCoord(0#, 0#, 1#), 0#)
Call targetGS.AppendHybridShape(oZero)
Call oPart.UpdateObject(oZero)
'now do the disassembly
Dim oZeroRef As Reference
Set oZeroRef = oPart.CreateReferenceFromObject(oZero)
'un-datum the curve by making a zero translate
Dim domains() As Variant
domains = oHSF.AddNewDatums(oZeroRef)
Dim i As Integer
For i = 0 To UBound(domains)
Call targetGS.AppendHybridShape(domains(i))
Next
Call oPart.Update
'now we can copy the resulting points...
Dim oSel As Selection
Set oSel = CATIA.ActiveDocument.Selection
Call oSel.add(targetGS)
Call oSel.Search("'Generative Shape Design'.Point,sel")
'copy paste into the new part
MsgBox ("There are " & oSel.count & " points ready to copy")
< YOUR COPY PASTE CODE GOES HERE>
'delete the temporary geo set
Call oHSF.DeleteObjectForDatum(oPart.CreateReferenceFromObject(targetGS))
End Sub
I have an .stp file, exported with a different CAD-software, which I can open with CATIA.
CATIA will then list the product/part tree as if it were a native CATIA .CATProduct.
My goal is to automate opening such an .stp file with CATIA and saving all contained parts/products with a name that is extracted from one of the UserRefProperties in each of these parts/products.
Therefore I want to create a macro with VBA which when completed will run in batch mode.
My first problem arises when I try to save the parts/products in this .stp file, Catia's save function handles my file as desired and will save each part/product as a separate file.
However, using VBA I can't seem to be able to save any of these parts/products since the .ExportData and .SaveAs methods only seem to work on .PartDocument or .ProductDocument objects instead of the objects which I've been trying to save:
.Product objects.
Example of what I'm trying to do:
Sub catmain()
Dim oProdDoc As ProductDocument
Set oProdDoc = CATIA.ActiveDocument
Dim oRootProd As Product
Set oRootProd = oProdDoc.Product
Dim oInstances As Products
Set oInstances = oRootProd.Products
For k = 1 To oInstances.Count
Dim oInst As Product
Set oInst = oInstances.Item(k)
oInst.ExportData "X:\path", ".CATPart"
next
end sub
If CATIA can save my .stp file's contents as desired, surely I can do the same with VBA, right?
Any help would be greatly appreciated.
The Product at the root of the tree can be saved as a CATProduct document.
Any sub-products within the tree can also be saved as a CATProduct.
The Parts, which are the leaves of the tree can be saved as CATParts.
You can save the root Product like this:
Dim rootProdDoc As ProductDocument
set rootProdDoc = CATIA.ActiveDocument
rootProdDoc.SaveAs "C:\Temp\" & rootProd.PartNumber & ".CATProduct"
However, when you do this, CATIA will complain that "This activates other save operations, do you want to continue?" It does this because the Parts are not yet saved. Answering yes CATIA will save your assembly and all the parts. However because you are not in control of the part saving it will preclude you from setting the names for those documents you want.
And because you have to answer a dialog, it will prevent you from making a batch program.
The right way to do this is to first save the leaf documents and then work "up" the tree the root level by level. Then everything will be saved when you need it to be.
----------Class clsSaveInfo definition--------------
Public level As Integer
Public prod As Product
-----------------(module definition)---------------
Option Explicit
Sub CATMain()
CATIA.DisplayFileAlerts = False
'get the root product
Dim rootProd As Product
Set rootProd = CATIA.ActiveDocument.Product
'make a dictionary to track product structure
Dim docsToSave As Scripting.Dictionary
Set docsToSave = New Scripting.Dictionary
'some parameters
Dim level As Integer
Dim maxLevel As Integer
'read the assembly
level = 0
Call slurp(level, rootProd, docsToSave, maxLevel)
Dim i
Dim kx As String
Dim info As clsSaveInfo
Do Until docsToSave.count = 0
Dim toRemove As Collection
Set toRemove = New Collection
For i = 0 To docsToSave.count - 1
kx = docsToSave.keys(i)
Set info = docsToSave.item(kx)
If info.level = maxLevel Then
Dim suffix As String
If TypeName(info.prod) = "Part" Then
suffix = ".CATPart"
Else
suffix = ".CATProduct"
End If
Dim partProd As Product
Set partProd = info.prod
Dim partDoc As Document
Set partDoc = partProd.ReferenceProduct.Parent
partDoc.SaveAs ("C:\Temp\" & partProd.partNumber & suffix)
toRemove.add (kx)
End If
Next
'remove the saved products from the dictionary
For i = 1 To toRemove.count
docsToSave.Remove (toRemove.item(i))
Next
'decrement the level we are looking for
maxLevel = maxLevel - 1
Loop
End Sub
Sub slurp(ByVal level As Integer, ByRef aProd As Product, ByRef allDocs As Scripting.Dictionary, ByRef maxLevel As Integer)
'increment the level
level = level + 1
'track the max level
If level > maxLevel Then maxLevel = level
'see if the part is already in the save list, if not add it
If allDocs.Exists(aProd.partNumber) = False Then
Dim info As clsSaveInfo
Set info = New clsSaveInfo
info.level = level
Set info.prod = aProd
Call allDocs.add(aProd.partNumber, info)
End If
'slurp up children
Dim i
For i = 1 To aProd.products.count
Dim subProd As Product
Set subProd = aProd.products.item(i)
Call slurp(level, subProd, allDocs, maxLevel)
Next
End Sub
I'm currently trying to control/automate a postcode looking website from postcodes stored and updated in Excel, and my code works perfectly up to the point it has to copy the data once it's finished. For the life of me I can't figure out how to copy the data from the text box / area into Excel without it just putting it ALL into one cell (Text to Columns doesn't really work either).
The website is : http://www.doogal.co.uk/DrivingDistances.php
Sub Geo2()
Dim sht As Worksheet
Dim IE As Object
'Dim ieDoc As HTMLDocument
Dim Item As Variant
Dim objElement As Object
Dim startLoc As String
Dim endLoc As String
Dim x As Integer
Dim objNotes As Object
Dim strNotes As String
Dim str As String
'Dim SignInButton As HTMLInputButtonElement
Set sht = ThisWorkbook.Sheets("Postcode")
Set IE = CreateObject("InternetExplorer.Application")
'Open IE
IE.Visible = True
IE.Navigate "http://www.doogal.co.uk/DrivingDistances.php"
'Wait until site is loaded
Do While IE.ReadyState <> 4 'READYSTATE_COMPLETE
DoEvents
Loop
IE.Document.getElementbyID("startLocs").Value = "dn1 5pq" 'random postcode
IE.Document.getElementbyID("endLocs").Value = "wf12 2fd" 'random postcode
IE.Document.getElementsByName("calculateFor").Item(1).Checked = True
IE.Document.getElementsByName("units").Item(1).Checked = True
IE.Document.getElementsByClassName("btn btn-primary").Item(0).Click
------
'Ive tried without having it as a object and using .value but it either comes with only the first line or the entire thing rammed into a string and is unusable
----Code here is the problem-----
***Set objNotes = IE.Document.getElementbyID("distances")
str = objNotes.Value***
---------
Do While IE.ReadyState <> 4 'READYSTATE_COMPLETE
DoEvents
Loop
End Sub
The following VBA function uses the Google Maps Directions API to calculate the driving distance in meters between two locations. The code is modified from a version submitted by barrowc on this similar question.
Make sure to add a reference in Excel to Microsoft XML, v6.0.
Function getDistance(origin As String, destination As String) As String
Dim xhrRequest As XMLHTTP60
Dim domDoc As DOMDocument60
Dim ixnlDistanceNode As IXMLDOMNode
Dim RequestString As String
Dim API_Key As String
' Insert your own Google Maps Directions API key here
API_Key = "XXXXXX"
' Read the data from the website
Set xhrRequest = New XMLHTTP60
RequestString = "https://maps.googleapis.com/maps/api/directions/xml?origin=" _
& origin & "&destination=" & destination & "&sensor=false&key=" & API_Key
xhrRequest.Open "GET", RequestString, False
xhrRequest.send
' Copy the results into a format we can manipulate with XPath
Set domDoc = New DOMDocument60
domDoc.LoadXML xhrRequest.responseText
' Select the node called value underneath the leg and distance parents.
' The distance returned is the driving distance in meters.
Set ixnlDistanceNode = domDoc.SelectSingleNode("//leg/distance/value")
getDistance = ixnlDistanceNode.Text
Set ixnlDistanceNode = Nothing
Set domDoc = Nothing
Set xhrRequest = Nothing
End Function
Please note that this code by itself violates the Terms of Use of Google's API. "The Google Maps Directions API may only be used in conjunction with displaying results on a Google map; using Directions data without displaying a map for which directions data was requested is prohibited."1
Instead of putting the data all in one string, Split the string into an array, then loop through the array like this:
Set objNotes = IE.Document.getElementbyID("distances")
Dim x as Integer
Dim aDist() as Variant
aDist = Split(objNotes.Value, vbNewLine) 'May need to be vbCr or vbLf or vbCrLf
For x = 0 to Ubound(aDist) - 1
debug.print aDist(x)
Next x