I have recently started using vb.net for programming.
I am trying to get the X-Y coordinates of all the shapes in visio into a csv file.
I found a VBA code by Russell Christopher in which the code does exactly what I need, but it is in VBA. I tried rewriting the code in VB.net but as I am new, I do not know all of the syntax. Can anyone here please help me on that.
Here is the code that I need to convert.
Public Sub WriteTableauPointsFile()
Dim oShape As Visio.Shape
Dim oPath As Visio.Path
Dim oPoints() As Double
'Set the output file to be the same as the source file, but .CSV
oFileName = Left(ActiveDocument.FullName, Len(ActiveDocument.FullName) - 3) & "csv"
'Set the separator character
oSeparator = "|"
'If file already exists, delete it
If Dir(oFileName) <> "" Then
Kill oFileName
End If
'Open the output file and write the header line
oFile = FreeFile
Open oFileName For Append As #oFile
Print #oFile, "ShapeNo" & oSeparator & "ShapeName" & oSeparator & "PathNo" & oSeparator & "PointNo" & oSeparator & "X" & oSeparator & "Y"
'Get all the shapes on the page
ActiveWindow.SelectAll
Set oShapes = ActiveWindow.Selection
'Cycle through the shapes
For Each oShape In oShapes
'Shapes can have multiple paths
For j = 1 To oShape.Paths.Count
Set oPath = oShape.Paths(j)
'Enumerate the points in each path with 0.5 sensitivity for curves
oPath.Points 0.5, oPoints
i = 0
Do While i < UBound(oPoints)
x = Int(oPoints(i))
y = Int(oPoints(i + 1))
i = i + 2
'Write the record for each point
Print #oFile, oShape.Index; oSeparator; oShape.Text; oSeparator; j; oSeparator; i; oSeparator; x; oSeparator; y
Loop
Next j
Next
'Close the file and exit
Close #oFile
End Sub
Based on trial and error I understood that there is no such thing as "open" in vb.net. I was able to successfully convert until the "open" statement starts.
Any help will be really appreciated.
Thanks,
- Miki
I figured out the answer myself. Thought I would post it here so that it might be helpful someone looking for similar thing in future.
Dim oPoints() as Double
oPath.Points(0.5, oPoints)
i = 0
Do While i < UBound(oPoints)
x = Int(oPoints(i))
y = Int(oPoints(i + 1))
i = i + 2
Remaining portion of the code remains the same.
Related
I have a big table in ms-word that contains 85 contentcontrols (combo boxes). I want to change the content using a vba loop (see below). It takes longer than one minute for it to complete...
Are there other options?
Private Sub Btn_Clear1_Click()
Dim a
Dim c As ContentControl
a = FindTable(ActiveDocument.Name, "myTableName")(1) 'returns an array(Long) with number of table found
For Each c In ActiveDocument.Tables(a).Range.ContentControls
c.Range.text = "MY CHANGED TEXT"
Next c
End Sub
Thanks in advance for any hint!
Here, turning off screenupdating reduces the time from about 6 seconds to less than 1 second. e.g.
On Error Goto turnscreenon
Application.Screenupdating = False
For Each c In ActiveDocument.Tables(a).Range.ContentControls
c.Range.text = "MY CHANGED TEXT"
Next c
turnscreenon:
Application.Screenupdating = True
That may only work on the Windows version of Word.
If you know exactly how many combo boxes there are going to be, you could consider creating a custom xml part containing an array of XML Elements to contain the values. Map each content control to one of those elements. Then instead of writing the values to the content control ranges, write them to the XML Part and let Word do the work. That works almost instantaneously here.
e.g. in a simple scenario where you just have those 85 content controls in the table, you could set up the Custom XML Part like this (I leave you to write any code that you need to delete old versions). You should only need to run this once.
Sub createCxpAndLink()
' You should choose your own Uri
Const myNamespaceUri As String = "mycbcs"
Dim a
Dim i As Long
Dim s As String
Dim cxp As Office.CustomXMLPart
With ActiveDocument
a = FindTable(.Name, "myTableName")(1)
s = ""
s = s & "<?xml version='1.0' encoding='UTF-8'?>" & vbCrLf
s = s & "<cbcs xmlns='" & myNamespaceUri & "'>" & vbCrLf
For i = 1 To .Tables(a).Range.ContentControls.Count
s = s & " <cbc/>" & vbCrLf
Next
s = s & "</cbcs>"
Set cxp = .CustomXMLParts.Add(s)
With .Tables(a).Range.ContentControls
For i = 1 To .Count
.Item(i).XMLMapping.SetMapping "/x:cbcs[1]/x:cbc[" & Trim(CStr(i)) & "]", "xmlns:x='" & myNamespaceUri & "'", cxp
Next
End With
Set cxp = Nothing
End With
End Sub
Then to update the contents you need something like this
Sub testsetxml()
Const myNamespaceUri As String = "mycbcs"
Dim i As Long
'our start time...
Debug.Print Now
With ActiveDocument.CustomXMLParts.SelectByNamespace(myNamespaceUri)(1)
For i = 1 To 85
.SelectNodes("/ns0:cbcs[1]/ns0:cbc[" & Trim(CStr(i)) & "]")(1).Text = "my changed text "
' or if you want to put different texts in different controls, you can test using e.g.
.SelectNodes("/ns0:cbcs[1]/ns0:cbc[" & Trim(CStr(i)) & "]")(1).Text = "my changed text " & Cstr(i)
Next
End With
'our end time...
Debug.Print Now
End Sub
(NB you cannot do it by mapping all the controls to a single XML element because then all the dropdowns will all be updated to the same value whenever you change the value of one of them.)
Apologies for any typos - I've changed the code to be more in line with what you have already and have not tested the changes.
I have an Excel sheet with almost 30.000 words in column A and I want to create a macro to search each word in Google Translate, get their meaning (or translation), put the meaing in column B (or if there is more than more meaning in column C, column D, etc.)
Since I have almost 30.000 words, it is a very time consuming thing to search for each word by myself. It would be great if I can do this with a macro.
Any suggestions? (Google Translate is not a "must" for me. If there is another web-site or some other way to do this, I am open to suggestions)
Note: I came across with this topic, but it did not work out the way I hoped.
Since the Google Translate API is not the free service it's tricker to perform this operation. However, I found a workaround on this page Translate text using vba and I made some adjustments so it could work for your purposes. Assuming that the original words are entered into the "A" column in the spreadsheet and translations should appear in the colums on the right here is the code:
Sub test()
Dim s As String
Dim detailed_translation_results, basic_translation_results
Dim cell As Range
For Each cell In Intersect(ActiveSheet.Range("A:A"), ActiveSheet.UsedRange)
If cell.Value <> "" Then
detailed_translation_results = detailed_translation(cell.Value)
'Check whether detailed_translation_results is an array value. If yes, each detailed translation is entered into separate column, if not, basic translation is entered into the next column on the right
On Error Resume Next
ActiveSheet.Range(cell.Offset(0, 1), cell.Offset(0, UBound(detailed_translation_results) + 1)).Value = detailed_translation_results
If Err.Number <> 0 Then
cell.Offset(0, 1).Value = detailed_translation_results
End If
On Error GoTo 0
End If
Next cell
End Sub
Function detailed_translation(str)
' Tools Refrence Select Microsoft internet Control
Dim IE As Object, i As Long, j As Long
Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String, CLEAN_DATA
Dim FirstTablePosition As Long, FinalTablePosition
Set IE = CreateObject("InternetExplorer.application")
' Choose input language - Default "auto"
inputstring = "auto"
' Choose input language - Default "en"
outputstring = "en"
text_to_convert = str
'open website
IE.Visible = False
IE.navigate "http://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert
Do Until IE.ReadyState = 4
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:5"))
Do Until IE.ReadyState = 4
DoEvents
Loop
'Firstly, this function tries to extract detailed translation.
Dim TempTranslation() As String, FinalTranslation() As String
FirstTablePosition = InStr(IE.Document.getElementById("gt-lc").innerHTML, "<tbody>")
LastTablePosition = InStr(IE.Document.getElementById("gt-lc").innerHTML, "</tbody>")
On Error Resume Next
TempTranslation() = Split(Mid(IE.Document.getElementById("gt-lc").innerHTML, FirstTablePosition, LastTablePosition - FirstTablePosition), "class=""gt-baf-cell gt-baf-word-clickable"">")
ReDim FinalTranslation(0 To UBound(TempTranslation) - 1)
For j = LBound(TempTranslation) + 1 To UBound(TempTranslation)
FinalTranslation(j - 1) = Left(TempTranslation(j), InStr(TempTranslation(j), "<") - 1)
Next j
On Error GoTo 0
Dim CheckIfDetailed
'Check whether there is detailed translation available. If not - this function returns a single translation
On Error Resume Next
CheckIfDetailed = FinalTranslation(LBound(FinalTranslation))
If Err.Number <> 0 Then
CLEAN_DATA = Split(Application.WorksheetFunction.Substitute(IE.Document.getElementById("result_box").innerHTML, "</SPAN>", ""), "<")
For j = LBound(CLEAN_DATA) To UBound(CLEAN_DATA)
result_data = result_data & Right(CLEAN_DATA(j), Len(CLEAN_DATA(j)) - InStr(CLEAN_DATA(j), ">"))
Next
detailed_translation = result_data
Exit Function
End If
On Error GoTo 0
IE.Quit
detailed_translation = FinalTranslation()
End Function
Please note that the code is extremly slow (due to anti-robot restrictions) and I cannot guarantee that Google will not block the script. However, it should work.
The only thing you should do is to choose languages in the places marked by the appropriate comment.
Alternatively, if you seek something faster, you can manipulate Application.Wait method (for example setting the value to 0:00:2 instead of 0:00:5) or google for Microsoft Translate.
I have the below in VBA that I use to write an array in a specific format to a CSV file (partly this is to get aorund excel putting "" around every cell when saving normally).
I am now trying to transfer accross to VB.net.
I have had a look aorund and tried various iterations of options to no avail.
Sub WriteCSV(varHoldingsArray, strTempLocation)
Dim i, j As Integer
Dim strCompiled As String
Open strTempLocation For Output As #1
For i = LBound(varHoldingsArray, 2) To UBound(varHoldingsArray, 2)
For j = LBound(varHoldingsArray, 1) To UBound(varHoldingsArray, 1)
Select Case j
Case Is > LBound(varHoldingsArray, 2)
strCompiled = strCompiled & varHoldingsArray(j, i)
Case LBound(varHoldingsArray, 2)
strCompiled = strCompiled & "," & varHoldingsArray(j, i)
End Select
Next j
If i <> UBound(varHoldingsArray, 2) Then
strCompiled = strCompiled & vbNewLine
End If
Next i
Print #1, strCompiled
Close #1
End Sub
My issue comes around opening the file printing to it.
I replaced:
Open strTempLocation For Output As #1
with:
File.Create(strTempLocation) For Output As #1
althought the "For Output" part as used in VBA doesn't seem to be expected (this is where I get lost). I have referenced System and System.IO in the project.
I'm then after the the .net equivalents of the following at the end:
Print #1, strCompiled
Close #1
A easy method would be
My.Computer.FileSystem.WriteAllText("c:\filename", "text", False)
MSDN
Please bear with my limited knowledge in CATIA VBA.
I am having some difficulties in customize a CATIA V5 macro to browse for Excel coordinate points and plot it in CATIA, all with a click on the customized CATIA icon.
I got an Excel file with many XYZ coordinates, let call it ExcelP1
(The excel file has no scripts/Macro in it), I would like to develop
a macro in CATIA to read & plot points from ExcelP1.
Currently i have another "Excel file with macro" to browse the
ExcelP1, and plot the points in CATIA. But i need to open and run
the "Excel file with macro" first to initiate CATIA. The scripts are
as below (i didn't develop this)
Public Filename As String
Private Sub Browse_Click()
'Open File
Mainform.Hide
Filename = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If Filename <> "False" Then
Application.Visible = False
filenamebox.Value = Filename
Else
Application.Visible = False
Filename = filenamebox.Value
End If
Mainform.Show
End Sub
Private Sub ClearButton_Click()
Mainform.Hide
ActiveWorkbook.Close (False)
Application.Visible = False
End Sub
Private Sub OKButton_Click()
'Set Up Message Labels
Title = "Information Message"
'Check for Entered Values
If filenamebox.Value <> "" Then
Workbooks.Open Filename:=Filename
Application.Visible = False
'Start CATIA and add an Open body to the document
Start_CATIA
Mainform.Hide
'Read Point Data from file and create point in CATIA
i = 2
Do Until Worksheets("Sheet1").Range("a" & i).Value = ""
x = Worksheets("Sheet1").Range("a" & i).Value
y = Worksheets("Sheet1").Range("b" & i).Value
z = Worksheets("Sheet1").Range("c" & i).Value
Create_Point
i = i + 1
Loop
i = i - 2
MsgBox i & " Points Created in New Part", , Title
Else
MsgBox "Enter a Filename", , Title
End If
ActiveWorkbook.Close (False)
Mainform.Show
End Sub
Private Sub UserForm_Initialize()
If Worksheets("Filepath_Location").Range("a1").Value <> "" Then
Filename = Worksheets("Filepath_Location").Range("a1").Value
filenamebox.Value = Filename
End If
End Sub
What do I need to add/modify in order for the scripts to run in CATIA?
The first thing you need to do after you start Catia and get the application is to create a new Part in which you will be adding the points.
Dim MyPartDocument As PartDocument
Dim MyPart As Part
Dim PointGeoSet As HybridBody
Set MyPartDocument = CATIA.Documents.Add("Part")
Set MyPart = MyPartDocument.Part
Set PointGeoSet = MyPart.HybridBodies.Add()
PointGeoSet.Name = "MyPoints"
The next thing is to create the point from the excel data by using a function like this. I like to create a wrapper, but you can rewrite this anyway you want:
Sub CreateXYZPoint(TargetPart As Part, TargetGeometricalSet As HybridBody, _
Xmm As Double, Ymm As Double, Zmm As Double, _
PointCount As String)
Dim HSFactory As HybridShapeFactory
Dim NewPoint As Point
'get the factory
Set HSFactory = TargetPart.HybridShapeFactory
'create the point with the factory
Set NewPoint = HSFactory.AddNewPointCoord(Xmm, Ymm, Zmm)
'Append the point to the geometrical set
TargetGeometricalSet.AppendHybridShape NewPoint
'rename the point
NewPoint.Name = "Point." & PointCount
End Sub
You Would call
CreateZYXPoint MyPart, PointGeoSet,x,y,z,cstr(i) in your loop
Finally, at the end of your loop, you will want to update the part so call:
MyPart.Update
It is much faster to do a single update at the end of your program than to update after each point is created.
This should get you started. Remember, Catia uses Millimeters as it's base internal units. Therefore, your spreadsheet match units or you must do a unit conversion before calling CreateXYZPoint...or However you want to accomplish that.
Let me know if this works for you.
Edit: Here's a link to the code put together with your code above. You need to make sure you excel code is working, but where I inserted the Catia code is correct:
http://pastebin.com/vxFcPw52
I need to automate the creation of a presentation (either OpenOffice or Powerpoint). The presentation should take the first two slides of each of the presentations in a given directory, and then combine them into a single presentation. I'm confused as to what approach I should take to solve this. Any pointers will be appreciated.
Talking about PowerPoint, you would use a VBA Macro to do the job, something like
Sub Pull()
Dim SrcDir As String, SrcFile As String
SrcDir = PickDir()
If SrcDir = "" Then Exit Sub
SrcFile = Dir(SrcDir & "\*.ppt")
Do While SrcFile <> ""
ImportFromPPT SrcDir + "\" + SrcFile, 1, 2
SrcFile = Dir()
Loop
End Sub
Selecting your source directory you can use this function
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = ""
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "Pick a directory to work on"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
End Function
Now - the main point is inserting slides from another PPT while preserving the source format. This is a tricky thing, as the PPT VBA InsertFromFile method is of no good use. Microsoft gave us good time to figure it out the hard way in countless 20hrs debuging sessions :-) and you need to type a lot of code to get it done correctly - far more complicated than using the dialogue manually, in particular if your source slide deviates from your source master slide.
If your PPT's are sticking to their masters, you can safely omit all code between the ">>>>"
Private Sub ImportFromPPT(FileName As String, SlideFrom As Long, SlideTo As Long)
Dim SrcPPT As Presentation, SrcSld As Slide, Idx As Long, SldCnt As Long
Set SrcPPT = Presentations.Open(FileName, , , msoFalse)
SldCnt = SrcPPT.Slides.Count
If SlideFrom > SldCnt Then Exit Sub
If SlideTo > SldCnt Then SlideTo = SldCnt
For Idx = SlideFrom To SlideTo Step 1
Set SrcSld = SrcPPT.Slides(Idx)
SrcSld.Copy
With ActivePresentation.Slides.Paste
.Design = SrcSld.Design
.ColorScheme = SrcSld.ColorScheme
' if slide is not following its master (design, color scheme)
' we must collect all bits & pieces from the slide itself
' >>>>>>>>>>>>>>>>>>>>
If SrcSld.FollowMasterBackground = False Then
.FollowMasterBackground = False
.Background.Fill.Visible = SrcSld.Background.Fill.Visible
.Background.Fill.ForeColor = SrcSld.Background.Fill.ForeColor
.Background.Fill.BackColor = SrcSld.Background.Fill.BackColor
' inspect the FillType object
Select Case SrcSld.Background.Fill.Type
Case Is = msoFillTextured
Select Case SrcSld.Background.Fill.TextureType
Case Is = msoTexturePreset
.Background.Fill.PresetTextured (SrcSld.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
' TextureName gives a filename w/o path
' not implemented, see picture handling
End Select
Case Is = msoFillSolid
.Background.Fill.Transparency = 0#
.Background.Fill.Solid
Case Is = msoFillPicture
' picture cannot be copied directly, need to export and re-import slide image
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = False
bMasterShapes = SrcSld.DisplayMasterShapes
SrcSld.DisplayMasterShapes = False
SrcSld.Export SrcPPT.Path & SrcSld.SlideID & ".png", "PNG"
.Background.Fill.UserPicture SrcPPT.Path & SrcSld.SlideID & ".png"
Kill (SrcPPT.Path & SrcSld.SlideID & ".png")
SrcSld.DisplayMasterShapes = bMasterShapes
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = True
Case Is = msoFillPatterned
.Background.Fill.Patterned (SrcSld.Background.Fill.Pattern)
Case Is = msoFillGradient
' inspect gradient type
Select Case SrcSld.Background.Fill.GradientColorType
Case Is = msoGradientTwoColors
.Background.Fill.TwoColorGradient
SrcSld.Background.Fill.GradientStyle , _
SrcSld.Background.Fill.GradientVariant
Case Is = msoGradientPresetColors
.Background.Fill.PresetGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Background.Fill.OneColorGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.GradientDegree
End Select
Case Is = msoFillBackground
' Only shapes - we shouldn't come here
End Select
End If
' >>>>>>>>>>>>>>>>>>>>
End With
Next Idx
End Sub
The code doesn't check for read-only or password protected fies and will crash on them. Also be careful not to run over the collector file itself. Otherwise it should work. I must admit I haven't reviewed the code for a long time ;-)
You can google "powerpoint join" to find a useful tool to join many ppts.
I'm glad #miked was able to get you what you needed.
Another method to consider, if using .NET, is discussed in this post
A simple and fast solution:
I := Presentation.Slides.InsertFromFile(FileName,X,StartSlideNo,EndSlideNo);
Presentation.Slides.Item(I).ApplyTheme(FileName);
Presentation.Slides.Item(I).ApplyTemplate(FileName);
Note:
X is place to insert slide in presentation
I is actual place where slide was inserted
Code is written in Delphi/Pascal but you can convert it easelly ...
You can do this with Aspose.Slides for .NET. It even allows joining OpenOffice and PowerPoint presentations together. View this article.
var presentation1 = new Presentation("presentation1.pptx");
var presentation2 = new Presentation("presentation2.odp");
var mergedPresentation = new Presentation();
while (mergedPresentation.Slides.Count > 0) mergedPresentation.Slides.RemoveAt(0);
// Adding two slides from the first PPTX presentation
mergedPresentation.Slides.AddClone(presentation1.Slides[0]);
mergedPresentation.Slides.AddClone(presentation1.Slides[1]);
// Adding two slides from the second OPD presentation
mergedPresentation.Slides.AddClone(presentation2.Slides[0]);
mergedPresentation.Slides.AddClone(presentation2.Slides[1]);
mergedPresentation.Save("mergedPresentation.pptx", SaveFormat.Pptx);