I am tasked to find a way to help our design team to screen capture a specific position of a part. However, I don't know how to customize my own position.
I tried looking at some codes on the internet and I found this:
Sub CATMain()
Dim productDocument1 As Document
Set productDocument1 = CATIA.ActiveDocument
Dim cameras1 As Cameras
Set cameras1 = productDocument1.Cameras
Dim camera3D1 As Camera
Set camera3D1 = cameras1.Item(1)
Dim viewpoint3D1 As Viewpoint3D
Set viewpoint3D1 = camera3D1.Viewpoint3D
Dim specsAndGeomWindow1 As Window
Set specsAndGeomWindow1 = CATIA.ActiveWindow
Dim viewer3D1 As Viewer
Set viewer3D1 = specsAndGeomWindow1.ActiveViewer
viewer3D1.Viewpoint3D = viewpoint3D1
Set viewpoint3D1 = camera3D1.Viewpoint3D
viewer3D1.Viewpoint3D = viewpoint3D1
Dim filelocation As String
filelocation = "c:\Temporary\"
Dim extension As String
extension = ".jpg"
Dim Name as string
Name= filelocation & "right" & extension
viewer3D1.Viewpoint3D =camera3D1.Viewpoint3D
CATIA.ActiveDocument.Selection.Clear()
viewer3D1.Capturetofile 5,Name
Dim camera3D2 As Camera
Set camera3D2 = cameras1.Item(2)
Dim viewpoint3D2 As Viewpoint3D
Set viewpoint3D2 = camera3D2.Viewpoint3D
viewer3D1.Viewpoint3D = viewpoint3D2
Set viewpoint3D2 = camera3D2.Viewpoint3D
viewer3D1.Viewpoint3D = viewpoint3D2
Name = filelocation & "left" & extension
viewer3D1.Viewpoint3D =camera3D2.Viewpoint3D
CATIA.ActiveDocument.Selection.Clear()
viewer3D1.Capturetofile 5,Name
End Sub
Is there a way to tweak this code in terms of my own position that I want?
Thank you!
Related
I have a code that I was able to string together that logs my sent emails into an excel sheet so i can use that data for other analysis.
In it, I have it resolving the name into an email as outlook shortens it ("Jimenez, Ramon" = email#address.com) as outlook configured this and it works when i send an email to anyone in my company as they are in my address book.
Now, when I email anyone outside it defaults to lastName, firstName so it is not converting this and logging it.
I thought the code I have in here already does this, but I guess not. I have already come this far and I am NOT a software guru at all. Does anyone have insight on how I can also include this as well?? Please see code below:
Private WithEvents Items As Outlook.Items
Const strFile As String = "C:\Users\a0227084\Videos\work\test.xlsx"
Private Sub Application_Startup()
Dim OLApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set OLApp = Outlook.Application
Set objNS = OLApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
FullName = Split(Msg.To, ";")
For i = 0 To UBound(FullName)
If i = 0 Then
STRNAME = ResolveDisplayNameToSMTP(FullName(i))
Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
ElseIf ResolveDisplayNameToSMTP(FullName(i)) <> "" Then
STRNAME = ResolveDisplayNameToSMTP(FullName(i))
Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
End If
Next i
'Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Sub tes2t()
End Sub
Function getRecepientEmailAddress(eml As Variant)
Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array
For Each emlAddr In eml.Recipients
If Left(emlAddr.Address, 1) = "/" Then
' it's an Exchange email address... resolve it to an SMTP email address
out.Add ResolveDisplayNameToSMTP(emlAddr)
Else
out.Add emlAddr.Address
End If
Next
getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith#myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
Dim PR_SMTP_ADDRESS As String
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End Select
End If
End Function
Sub Write_to_excel(str1 As String, str2 As String, str3 As String)
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWH As Worksheet
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
Set sourceWB = Workbooks.Open(strFile, False, False)
Set sourceWH = sourceWB.Worksheets("Sheet1")
sourceWB.Activate
With sourceWH
lastrow = .Cells(.rows.Count, "A").End(xlUp).Row
End With
sourceWH.Cells(lastrow + 1, 1) = str1
sourceWH.Cells(lastrow + 1, 2) = str2
sourceWH.Cells(lastrow + 1, 3) = str3
sourceWB.Save
sourceWB.Close
End Sub
Error message and corrected code
Regards,
Ramon
First of all, there is no need to create a new Application instance in the ResolveDisplayNameToSMTP method:
Set OLApp = CreateObject("Outlook.Application")
Instead, you can use the Application property available in the Outlook VBA editor out of the box.
Second, you need to use the following code to get the SMTP address from the AddressEntry object:
Dim PR_SMTP_ADDRESS As String
Set PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
Instead of the following line:
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
Read more about that in the How to get the SMTP Address of the Sender of a Mail Item using Outlook Object Model? article.
i tried to follow the example on how to create a changeset with multiple files: [See link][1]
Although i am a bit stuck at the TFVCItem and ItemContent stage where i don't know how to extract the content and enconding of my file.
Im trying to write some code in order to checkin a file given to me by a filePath and check it in at a given location.
Would anyone care to help me out on how to do this?
This is what i came up so far:
Public Function CreateChangeset(ByVal projectName As String,
ByVal files As Dictionary(Of String, String),
ByVal comment As String) As TfvcChangesetRef
Dim c = TFSConnection.GetClient(Of TfvcHttpClient)
Dim newChangetset = New TfvcChangeset
Dim changes = New List(Of TfvcChange)
For Each fKP In files
Dim fileSource = fKP.Key
Dim fileTarget = fKP.Value
Dim newChange = New TfvcChange
newChange.ChangeType = VersionControlChangeType.Add
Dim newItem = New TfvcItem
newItem.Path = $"&/{projectName}/{fileTarget}"
newItem.ContentMetadata = New FileContentMetadata
'' TODO: How to extract the correct encoding, and type?...
'newItem.ContentMetadata.Encoding = GetFileEncoding(fileSource)
'newItem.ContentMetadata.ContentType = "text/plain"
'newChange.Item = newItem
'' TODO: How to extract the correct content, and type?...
'Dim newContent = New ItemContent
'newContent.Content = "Blabla"
'newContent.ContentType = ItemContentType.RawText
'newChange.NewContent = newContent
changes.Add(newChange)
Next
newChangetset.Changes = changes
newChangetset.Comment = comment
Dim changesetRef = c.CreateChangesetAsync(newChangetset).Result
Return changesetRef
End Function
UPDATE:
Ok so i managed to make it work but i still am not sure how to properly set the ContentType.
I have the choice between ItemContentType.RawText and ItemContentType.Base64Encoded but i am not sure when to use one or the other.
Here is the new code which seems to work:
Public Function CreateChangeset(ByVal projectName As String,
ByVal files As Dictionary(Of String, String),
ByVal comment As String) As TfvcChangesetRef
Dim c = TFSConnection.GetClient(Of TfvcHttpClient)
Dim newChangetset = New TfvcChangeset
Dim changes = New List(Of TfvcChange)
For Each fKP In files
' Extract and build our target and source paths.
Dim fileSource = fKP.Key
Dim fileTarget = fKP.Value
Dim fileName = IO.Path.GetFileName(fileSource)
Dim newChange = New TfvcChange
' Create the new TFVC item which will be checked-in.
Dim newItem = New TfvcItem
newItem.Path = $"$/{projectName}/{fileTarget}/{fileName}"
newItem.ContentMetadata = New FileContentMetadata
' Try to extract the item from the server.
Dim serverItem = c.GetItemAsync(newItem.Path).Result
If serverItem Is Nothing Then
' If the file is not on the server, then its a new file.
newChange.ChangeType = VersionControlChangeType.Add
Else
' Indicate that we are dealing with a file modification
' and specify which version we are editing.
newChange.ChangeType = VersionControlChangeType.Edit
newItem.ChangesetVersion = serverItem.ChangesetVersion
End If
' Read the file content to a stream.
Using reader = New StreamReader(fileSource,
Text.Encoding.Default,
True) ' This last parameter allows to extract the correct encoding.
Dim fileContent As String = String.Empty
' Read all the file content to a string so that we can store
' it in the itemcontent.
' NOTE: reading it also allows to retrieve the correct file enconding.
If reader.Peek() >= 0 Then
fileContent = reader.ReadToEnd
End If
' Set the file enconding and MIME Type.
newItem.ContentMetadata.Encoding = reader.CurrentEncoding.WindowsCodePage
newItem.ContentMetadata.ContentType = System.Web.MimeMapping.GetMimeMapping(fileSource)
newChange.Item = newItem
' Set the file content.
Dim newContent = New ItemContent
newContent.Content = fileContent
' TODO: What should be the logic to set the Content Type? Not too sure...
' If newItem.ContentMetadata.ContentType.StartsWith("text/") Then
newContent.ContentType = ItemContentType.RawText
' Else
' newContent.ContentType = ItemContentType.Base64Encoded
' End If
' Store the content to the change.
newChange.NewContent = newContent
End Using
changes.Add(newChange)
Next
newChangetset.Changes = changes
newChangetset.Comment = comment
Dim changesetRef = c.CreateChangesetAsync(newChangetset).Result
Return changesetRef
End Function
I have more than 40 check-boxes in a single calc sheet, and I don't want to code each one of them. I just want a clear working code to get the name of checkbox.
In this program I have to manually type the name for the check-box within the macro code:
A="CheckBox1"
This is all I have so far:
Sub Marco1
Dim ocheckbox1
Dim oForm
Dim A
A="CheckBox1"
oForm = ThisComponent.Sheets(0).DrawPage.Forms.getByIndex(0)
ocheckbox1 = oForm.getByName(A)
if ocheckbox1.State = "0" then
if MsgBox ("Are you sure ?Note: It can't be re-edited", 292) = 6 then
ocheckbox1.Label = "Checked"
ocheckbox1.Enabled="False"
else
ocheckbox1.Label = "Not Checked"
End if
End if
End Sub
Assuming the macro is triggered by interaction with the checkbox:
Sub Macro1 (oEvent As Object)
Dim oCheckbox1 As Object
Dim sCheckbox1Name As String
oCheckbox1 = oEvent.source.model
sCheckbox1Name = oCheckbox1.Name
End Sub
This is probably a newbie mistake where I'm not aware of some setting that I haven't changed. Anyways, I'm trying use Dictionary to store a instances of class I've created.
Class cls_Connote is just a container of details.
Public connoteNumber As String
Public despatchDate As Date
Public carrier As String
Public service As String
Public items As Integer
Public weight As Integer
Public cost As Single
Public surchargeType As String
Here is how I'm storing the details into the class then into the dictionary.
Function getSurcharge_tag(givenTag As String, givenCol As String, ByRef dicStore As Dictionary, ByRef counter As Integer)`
Dim tagLen As Integer
Dim conNum, conTag As String
Dim clsSurchargeDetails As New cls_Connote
Dim despatchDate, carrier As String
Dim items, weight As Integer
Dim cost As Single
Range(givenCol).Select
tagLen = Len(givenTag)
Do While (ActiveCell.Value <> "")
conNum = Mid(ActiveCell.Value, 1, Len(ActiveCell.Value) - 1)
conTag = Mid(ActiveCell.Value, Len(ActiveCell.Value) - tagLen + 1, Len(ActiveCell.Value))
If (conTag = givenTag) Then 'Remove: both the Original and Adjusted connote lines
despatchDate = ActiveCell.Offset(0, -2).Value
items = ActiveCell.Offset(0, 10).Value
weight = ActiveCell.Offset(0, 11).Value
cost = ActiveCell.Offset(0, 12).Value
clsSurchargeDetails.connoteNumber = conNum
clsSurchargeDetails.despatchDate = despatchDate
clsSurchargeDetails.carrier = carrier
clsSurchargeDetails.items = items
clsSurchargeDetails.weight = weight
clsSurchargeDetails.cost = cost
clsSurchargeDetails.surchargeType = givenTag
dicStore.Add conNum, clsSurchargeDetails
givenCtr = givenCtr + 1
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Function
This is how I'm trying to get the connotes out of the Dictionary.
Function displaySurcharges(wrkShtName As String, ByRef dicList As Dictionary)
'Remove the existing worksheet
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = Sheets(wrkShtName)
On Error GoTo 0
If Not wrkSht Is Nothing Then
Worksheets(wrkShtName).Delete
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wrkShtName
populateColumnHeaders
Range("A2").Select
Dim getCon As cls_Connote
Set getCon = New cls_Connote
Dim vPtr As Variant
Dim ptrDic As Integer
For Each vPtr In dicList.Keys
Set getCon = dicList.Item(vPtr)
ActiveCell.Value = getCon.connoteNumber
ActiveCell.Offset(0, 1).Value = getCon.despatchDate
ActiveCell.Offset(0, 2).Value = getCon.carrier
ActiveCell.Offset(0, 12).Value = getCon.items
ActiveCell.Offset(0, 13).Value = getCon.weight
ActiveCell.Offset(0, 15).Value = getCon.cost
ActiveCell.Offset(0, 16).Value = getCon.surchargeType
Set getCon = Nothing
ActiveCell.Offset(1, 0).Select
Next vPtr
End Function
I can see dicList does contain different details, getCon only gets the last entry in the Dictionary.
Any help would be fantastic !
To avoid reusing and adding the same reference within the loop, when you need a new instance (after If (conTag = givenTag)) just ask for one:
Set clsSurchargeDetails = New cls_Connote
Last time I used two parameter to query & show report. It worked well. Right now I am trying to use same code with another extra parameter but its not working. I am confused. Let me show you my code.
Code which worked well:
Parameter fields : bdate and edate
Crystal report formula : {Bal_sheet.bsdate} >= {?bdate} and {Bal_sheet.bsdate} <= {?edate}
Code to show report :
Private Sub butsbalsrep_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles butsbalsrep.Click
Dim cryRpt As New ReportDocument
cryRpt.Load(Application.StartupPath & "\CrystalReport3.rpt")
Dim crParameterFieldDefinitions As ParameterFieldDefinitions
Dim crParameterFieldDefinition As ParameterFieldDefinition
Dim crParameterFieldDefinitions1 As ParameterFieldDefinitions
Dim crParameterFieldDefinition1 As ParameterFieldDefinition
Dim crParameterValues As New ParameterValues
Dim crParameterValues1 As New ParameterValues
Dim crParameterDiscreteValue As New ParameterDiscreteValue
Dim crParameterDiscreteValue1 As New ParameterDiscreteValue
crParameterDiscreteValue.Value = cmbbdate.Text
crParameterDiscreteValue1.Value = cmbedate.Text
crParameterFieldDefinitions = cryRpt.DataDefinition.ParameterFields
crParameterFieldDefinition = crParameterFieldDefinitions.Item("bdate")
crParameterFieldDefinitions1 = cryRpt.DataDefinition.ParameterFields
crParameterFieldDefinition1 = crParameterFieldDefinitions.Item("edate")
crParameterValues = crParameterFieldDefinition.CurrentValues
crParameterValues1 = crParameterFieldDefinition1.CurrentValues
crParameterValues.Clear()
crParameterValues1.Clear()
crParameterValues.Add(crParameterDiscreteValue)
crParameterValues1.Add(crParameterDiscreteValue1)
crParameterFieldDefinition.ApplyCurrentValues(crParameterValues)
crParameterFieldDefinition1.ApplyCurrentValues(crParameterValues1)
crysrepbalsht.ReportSource = cryRpt
crysrepbalsht.Refresh()
End Sub
Code which is not working:
Parameter fields : idnmb and acyer and etyp
Crystal report formula : {res_info.stu_id} = {?idnmb} and {res_info.yr} = {?acyer} and {res_info.etype} = {?etyp}
Code to show report :
Private Sub butsrrepsr_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles butsrrepsr.Click
Dim cryRpt As New ReportDocument
cryRpt.Load(Application.StartupPath & "\CrystalReport3.rpt")
Dim crParameterFieldDefinitions As ParameterFieldDefinitions
Dim crParameterFieldDefinition As ParameterFieldDefinition
Dim crParameterFieldDefinitions1 As ParameterFieldDefinitions
Dim crParameterFieldDefinition1 As ParameterFieldDefinition
Dim crParameterFieldDefinitions2 As ParameterFieldDefinitions
Dim crParameterFieldDefinition2 As ParameterFieldDefinition
Dim crParameterValues As New ParameterValues
Dim crParameterValues1 As New ParameterValues
Dim crParameterValues2 As New ParameterValues
Dim crParameterDiscreteValue As New ParameterDiscreteValue
Dim crParameterDiscreteValue1 As New ParameterDiscreteValue
Dim crParameterDiscreteValue2 As New ParameterDiscreteValue
crParameterDiscreteValue.Value = cmbsrrepidn.Text
crParameterDiscreteValue1.Value = cmbsrrepay.Text
crParameterDiscreteValue2.Value = cmbsrrepet.Text
crParameterFieldDefinitions = cryRpt.DataDefinition.ParameterFields
crParameterFieldDefinition = crParameterFieldDefinitions.Item("idnmb")
crParameterFieldDefinitions1 = cryRpt.DataDefinition.ParameterFields
crParameterFieldDefinition1 = crParameterFieldDefinitions.Item("acyer")
crParameterFieldDefinitions2 = cryRpt.DataDefinition.ParameterFields
crParameterFieldDefinition2 = crParameterFieldDefinitions.Item("etyp")
crParameterValues = crParameterFieldDefinition.CurrentValues
crParameterValues1 = crParameterFieldDefinition1.CurrentValues
crParameterValues2 = crParameterFieldDefinition2.CurrentValues
crParameterValues.Clear()
crParameterValues1.Clear()
crParameterValues2.Clear()
crParameterValues.Add(crParameterDiscreteValue)
crParameterValues1.Add(crParameterDiscreteValue1)
crParameterValues2.Add(crParameterDiscreteValue2)
crParameterFieldDefinition.ApplyCurrentValues(crParameterValues)
crParameterFieldDefinition1.ApplyCurrentValues(crParameterValues1)
crParameterFieldDefinition2.ApplyCurrentValues(crParameterValues2)
CrystalReportViewer3.ReportSource = cryRpt
CrystalReportViewer3.Refresh()
End Sub
I am confused why its not working! When I click on show report button it shows nothing(I dont get error message and getting no records back.). I have written {res_info.stu_id} = {?idnmb} and {res_info.yr} = {?acyer} and {res_info.etype} = {?etyp} it there in formula workshop-record selection formula editor. Please help me to get rid of this problem!
Yes you are right LittleBobbyTables. When I click on show report button it shows nothing(I dont get error message but getting no records back.) Yes I have written {res_info.stu_id} = {?idnmb} and {res_info.yr} = {?acyer} and {res_info.etype} = {?etyp} it there in formula workshop-record selection formula editor