Can't get sensible co-ordinates for note blocks - vba

I've been trying to resurrect an existing drawing check macro, and want to find the co-ordinates of any note blocks on each sheet. I've been modifying code found here using the GetAttachPos method from this page, but for some reason any co-ordinates returned come back around (8.80942311664557E-03,2.24429295226372E-03).
I'm thinking that the problem is that I've missed a reference somewhere, but I'm not sure where. Although it's definitely finding the notes since it passes back their text. Anyway, here's the method I'm testing at the moment:
Sub Main()
Dim swApp As SldWorks.SldWorks
Set swApp = CreateObject("SldWorks.Application")
Dim NoteNumbersText As String
Dim NoteText As String
Dim NumberofSheets As Integer ' The number of sheets in this drawing
Dim NamesOfSheets As Variant ' Names of all of the sheets
Dim sheet As SldWorks.sheet ' The Sheet that we are working on
Dim LocalView As SldWorks.View ' Current View that we are looking at
Dim LocalNote As SldWorks.Note ' Current Note that we are looking at
Dim TextFormat As SldWorks.TextFormat ' Current text format object of a note
Dim Xpos As Double ' X, Y Z position on the drawing in Metres
Dim Ypos As Double
Dim SizeOfSheet As Double
Dim x As Integer ' general Loop Variables
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim vPosition As Variant
Dim vNote As Variant ' Single note
Dim swNote As SldWorks.Note ' Single Solidworks Note Object
Dim ThisAnnotation As SldWorks.Annotation
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim NumofNotes As Integer
Dim ArrayOfNotes() As NoteInfo
Dim LocalDrawingDoc As SldWorks.DrawingDoc ' Declared as an Object so that non Drawings can be detected!
Dim LocalPart As SldWorks.ModelDoc2 ' Declared as an Object so that non Drawings can be detected!
Dim strShtProp As Variant
Set LocalDrawingDoc = swApp.ActiveDoc
Set LocalPart = swApp.ActiveDoc
ReDim ArrayOfNotes(0)
' Get the sheet names and the number of them
NamesOfSheets = LocalDrawingDoc.GetSheetNames()
NumberofSheets = LocalDrawingDoc.GetSheetCount
' store this sheet name
Set sheet = LocalDrawingDoc.GetCurrentSheet()
strShtProp = sheet.GetProperties() ' get the sheet properties use much later for converting position into ref
SizeOfSheet = strShtProp(5)
Dim SwSketchMgr As SldWorks.SketchManager
Set SwSketchMgr = LocalDrawingDoc.SketchManager
Dim i As Integer
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim strReturn As String
' Dim bret As Boolean
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
For x = NumberofSheets - 1 To 0 Step -1
If LocalDrawingDoc.GetCurrentSheet.GetName <> NamesOfSheets(x) Then LocalDrawingDoc.ActivateSheet NamesOfSheets(x)
Set LocalView = LocalDrawingDoc.GetFirstView
While Not LocalView Is Nothing
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
vNote = swBlockDef.GetNotes
If Not IsEmpty(vNote) Then
For j = 0 To UBound(vNote)
Set swNote = vNote(j)
NoteNumbersText = Trim(swNote.GetText)
If Left(NoteNumbersText, 1) = "n" And Len(NoteNumbersText) > 1 And Len(NoteNumbersText) < 4 Then
Set ThisAnnotation = swNote.GetAnnotation
'vPosition = swNote.GetAttachPos
vPosition = ThisAnnotation.GetPosition
Xpos = vPosition(0)
Ypos = vPosition(1)
Debug.Print ("Note " & NoteNumbersText & ": " & Xpos & "," & Ypos)
End If
Next j
End If
Next i
End If
Set LocalView = LocalView.GetNextView
Wend
Next x
End Sub

Turns out that SolidWorks is set up to return positions of blocks relative to the drawing view on which they're placed. Calling GetXForm for the view which they are placed on then provides a way of calculating the absolute position of each note.

Related

Visual Basic CInt error

I am trying to make a function that looks at an image, and return the X pixel value.
When i run the code, it throws an error on the Int1=CInt(Xdim) line, saying "Type Mismatch (10080)"
If i hard-code the value i am testing into Xdim, it works fine.
Function ImgXDim(filename As String) As Integer ' Finds the X dimension in pixels of a loaded image
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim ImgSize As String
Dim Int1 As Integer
Dim Xdim As String
Dim strarray() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(MacroDir & "\PICS\")
Set objFile = objFolder.ParseName(filename)
ImgSize = objFile.ExtendedProperty("Dimensions") ' Returns string of "700 x 923"
strarray = Split(ImgSize, " x ") ' Split into 2 strings of "700" and "923"
Xdim = CStr(strarray(0)) ' Force Xdim to be a string of "700"
Int1 = CInt(Xdim) ' Convert Xdim to an integer
ImgXDim = Int1 ' Return Integer
End Function
First check if value can be converted to an integer:
If IsNumeric(Trim(Xdim)) then
Int1 = CInt(Xdim)
else
'for debug purposes
MsgBox ("XDim non-numeric or empty")
End If
Ok, i couldnt find what character was causing the issue, so i used this loop of code to pull out only numbers, and it seems to work.
For X = 1 To Len(Xdim)
If IsNumeric(Mid(Xdim, X, 1)) = True Then
holder = holder & Mid(Xdim, X, 1)
End If
Next X
Here the WIA version:
Function ImgXDim(filename As String) As Long
Dim imgWIA as New WIA.ImageFile 'Early Binding needs a reference to Windows Image Aquisition Library in VBA-Ide->Tools->References
'Dim imgWIA as Object 'Late Bound Version
'Set imgWIA = CreateObject("WIA.ImageFile")
imgWIA.LoadFile MacroDir & "\PICS\" & filename
ImgXDim = imgWIA.Width ' use .Height for height
End Function
As you see, just three lines of code and returns a long, not a string that needs parsing.
Useful functions for resize, rotate and more.
Also useful if you want to display Tiffs in a picture control (page by page) and more.

Small function to rearrange string array in VBA

I've been writing a macro for Solidworks in VBA, and at one point I'd like to rearrange the sheets in a drawing in the following way--if any of the sheets are named "CUT", bring that sheet to the front. Solidworks API provides a way to rearrange the sheets, but it requires an array of sheet names sorted into the correct order--fair enough. The way to get the sheet names looks to be this method.
So, I tried to write a small function to rearrange the sheets in the way I want. The function call I'm trying to use and the function are shown here
Function Call
Dim swApp As SldWorks.SldWorks
Dim swDrawing As SldWorks.DrawingDoc
Dim bool As Boolean
Set swApp = Application.SldWorks
Set swDrawing = swApp.ActiveDoc
.
.
.
bool = swDrawing.ReorderSheets(bringToFront(swDrawing.GetSheetNames, "CUT"))
Function Definition
Private Function bringToFront(inputArray() As String, _
stringToFind As String) As String()
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
Dim outputArray() As String
first = LBound(inputArray)
last = UBound(inputArray)
ReDim outputArray(first to last)
For i = first To last
If inputArray(i) = stringToFind Then
For j = first To (i - 1)
outputArray(j + 1) = inputArray(j)
Next j
For j = (i + 1) To last
outputArray(j) = inputArray(j)
Next j
outputArray(first) = stringToFind
End If
Next i
bringToFront = outputArray
End Function
The error I get is "Type mismatch: array or user defined type expected" on the function call line. I've done quite a bit of searching and I think what I'm messing up has to do with static vs dynamic arrays, but I haven't quite been able to get to the solution on my own.
Besides the corrections suggested in the comments, what is happening is that at the lines
bringToFront(j + 1) = inputArray(j)
and
bringToFront(first) = stringToFind
the compiler thinks you are trying to call recursively the function bringToFront. That is why it complains about the number of parameters in the error message. To fix this, just create another array as local array variable, with a different name, let us name it "ret", fill it appropriately, and assign it at the end before returning.
EDIT: Also, it is better to declare the arrays as Variant types to avoid interoperability problems between VB6 and .Net . This was the final issue
Private Function bringToFront(inputArray As Variant, _
stringToFind As String) As Variant
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
first = LBound(inputArray)
last = UBound(inputArray)
Dim ret() As String
ReDim ret(first To last)
For i = first To last
If inputArray(i) = stringToFind Then
For j = first To (i - 1)
ret(j + 1) = inputArray(j)
Next j
ret(first) = stringToFind
End If
Next i
bringToFront = ret
End Function

How to prevent link formatting from changes when editing link using VBA?

I'm currently using the following code to update all the links in my application:
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:\" + exportFileName + ".pdf"
End Sub
The problem is that when I update the links, they lose their formatting. How can I preserve the formatting of the hyperlink? I tried looking at the Copy and Paste methods, but it seems like what I would really need is Paste Special, which doesnt exist on the Range property on the Hyperlink object.
Try adding the following lines to capture the color and underline and then set it back after the address change
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
Dim undline AS Long
Dim clr AS Long
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
undline = hprlink.Range.Font.Underline
clr = hprlink.Range.Font.Color
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
hprlink.Range.Font.Color = clr
hprlink.Range.Font.Underline = undline
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:\" + exportFileName + ".pdf"
End Sub

Join more powerpoint presentations into one new presentation keeping the originally slide-layout in Lotusscript

I am working on a project that joins two or more pp presentations into one new presentation.
The selection of the original pp presentations is in a webbased Lotus Notes xPage and after the submit, Lotusscript talkes to the OLE Powerpoint object.
Adding the slides into the new Presentation in the right order is no problem.
The problem is that after the adding the original connection with the slides Template(s) is lost.
To solve this I found the next codesnippet:
Sub joiner()
Dim sFileName As String
Dim oDonor As Variant
Dim otarget As Variant
Dim i As Integer
On Error GoTo errhandler
Set otarget = ActivePresentation
Do While sFileName <> ""
Set oDonor = Presentations.Open(Environ("USERPROFILE") & "\Desktop\joiner\" & sFileName, msoFalse)
For i = 1 To oDonor.Slides.Count
oDonor.Slides(i).Copy
With otarget.Slides.Paste(otarget.Slides.Count + 1)
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With
Next i
oDonor.Close
Set oDonor = Nothing
sFileName = Dir()
Loop
End Sub
I have to declare the presentations oDonor and oTarget as a Variant because lotusscript doesn't understand Dim oTarget As Presentation
This is probably the reason why the code returns a typemismatch error at:
.Design = oDonor.Slides(i).Design
My questions are:
Am I doing the join the right way or is there a better solution?
Is there a solution for the typemismatch error?
*ps: The result presentation doesn't have to be editable, so maybe it is not necessary to add templates.
Update 04-10-2012:
The next code solves the template problem.
What still is missing now is the background image used by some slides.
See: https://stackoverflow.com/questions/12731691/how-to-export-a-backgroundimage-of-a-slide-to-the-filesystem
Dim oDonor As Variant
Dim h As Integer
Dim thetmplt As Variant
Dim thetmpltname As String
Dim thetmpltnew As Variant
Dim thetmpltnamenew As String
Set oDonor = PPApplication.Presentations.Open(tempdirectory +
jobid+CStr(filenamearray (i)),False,False,False)
thetmplt = oDonor.TemplateName
Call oDonor.SaveAs(tempdirectory +jobid+CStr(i)+ thetmplt+".pot" ,5, -1)
For h = 1 To oDonor.Slides.Count
Dim oTargetSlide As Variant
oDonor.Slides(h).Copy
Set oTargetSlide = newPres.Slides.Paste()
Next
Dim theubound As Variant
theubound = oDonor.Slides.Count
ReDim thearray(1 To k + theubound) As Variant
For k = k To k + oDonor.Slides.Count-1
thearray(k) = k
Next
Call newPres.Slides.Range(thearray()).ApplyTemplate(tempdirectory +
jobid+CStr(i+thetmplt+".pot")
oDonor.Close
Set oDonor = Nothing
This is just a hunch, but try:
Dim oTargetSlide as Variant
Set oTargetSlide = otarget.Slides.Paste(otarget.Slides.Count + 1)(1)
With oTargetSlide
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With

How to export to excel with specified month

Sub Initialize
'Copyright Botstation (www.botstation.com)
Dim session As New NotesSession
Dim wks As New NotesUIWorkspace
Dim db As NotesDatabase
Dim view As NotesView
Dim uiView As NotesUIView
Dim doc As NotesDocument
Dim column As NotesViewColumn
Dim row As Long,colcounter As Long,arrcnt As Long,arrcounter As Long, x As Long
Dim filename As String, currentvalue As String
Dim rowsatonce As Integer,cn As Integer
Dim xlApp As Variant, xlsheet As Variant,xlwb As Variant, xlrange As Variant, tempval As Variant
Dim DataArray
Dim VColumns List As String
ReDim DataArray(0, 80) As String
'80 columns is our expected max number of columns in the view. It's dynamically recomputed below to actual (lower) number. Change if the number of columns is larger.
Set db=session.CurrentDatabase
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True 'Excel program is visible (to avoid errors and see what is happening)
Set xlwb=xlApp.Workbooks.Add
Set xlsheet =xlwb.Worksheets(1)
Set uiView = wks.CurrentView
Set view = db.GetView( uiView.ViewName ) ' get the view currently open in UI
arrcnt=0
row=1
colcounter=0
rowsatonce=20
ForAll c In view.Columns
If c.isIcon<>True Then ' do not include icon columns
If c.Formula<>"""1""" And c.Formula<>"1" Then 'do not include columns which are used for counting docs (Total)
colcounter=colcounter+1
DataArray(row-1, colcounter-1) =c.Title
VColumns(CStr(cn))=CStr(cn)
End If
End If
cn=cn+1
End ForAll
ReDim Preserve DataArray(0, colcounter-1) As String
xlsheet.Range("A1").Resize(1, colcounter).Value = DataArray ' set column names
ReDim DataArray(rowsatonce-1, colcounter-1) As String
row=2
x=0
Set doc = view.GetFirstDocument
While Not ( doc Is Nothing )
ForAll col In VColumns
currentvalue=""
tempval= doc.ColumnValues(Val(col))
If IsArray(tempval) Then
ForAll v In tempval
If currentvalue="" Then
currentvalue=v
Else
currentvalue=currentvalue+","+v
End If
End ForAll
Else
currentvalue=tempval
End If
x=x+1
DataArray(arrcounter, x-1) =currentvalue
End ForAll
x=0
row=row+1
arrcounter=arrcounter+1
If arrcounter/rowsatonce=arrcounter\rowsatonce And arrcounter<>0 Then
xlsheet.Range("A"+Cstr(arrcnt*rowsatonce+2)).Resize(rowsatonce, colcounter).Value = DataArray
arrcnt=arrcnt+1
arrcounter=0
ReDim DataArray(rowsatonce-1, colcounter-1) As String
End If
Set doc = view.GetNextDocument (doc)
Wend
If arrcounter/rowsatonce<>arrcounter\rowsatonce And arrcounter>0 Then
' Redim Preserve DataArray(arrcounter, colcounter-1) As String
xlsheet.Range("A"+Cstr(arrcnt*rowsatonce+2)).Resize(arrcounter, colcounter).Value = DataArray
End If
MsgBox "Done"
End Sub
Once you have got the month that you want to include you can add a condition after this line:
While Not ( doc Is Nothing )
Compare the month (and probably year) with the (date) item on the document. You might need the NotesDateTime class to do this.
To filter the right month you can do this: (assuming you also need the year)
If year(date1) * 100 + month(date1) = year(date2) * 100 + month(date3)