I have a issue regarding constraining in assembly.
below is the code.
Sub catmain()
Dim CAT_documents As Documents
Set CAT_documents = CATIA.Documents
Dim prod_doc As ProductDocument
Set prod_doc = CATIA.ActiveDocument
Dim prod As Product
Set prod = prod_doc.Product
Call constraint_everything(prod)
End Sub
Sub constraint_everything(cProd As Product)
Dim constraints1 As Constraints
Set constraints1 = cProd.Connections("CATIAConstraints")
Dim temp As Product
If cProd.Products.Count > 0 Then
For i = 1 To cProd.Products.Count
Set temp = cProd.Products.Item(i)
Dim osel 'as Selection
Set osel = CATIA.ActiveDocument.Selection
On Error Resume Next
osel.Clear
osel.Add temp
Dim dispname As String
dispname = osel.Item(1).Reference.DisplayName & "!" & osel.Item(1).Reference.DisplayName
Dim ref As Reference
Set ref = cProd.Products.CreateReferenceFromName(dispname)
Dim constraint1 As Constraint
Set constraint1 = constraints1.AddMonoEltCst(catCstTypeReference, ref)
If (temp.Products.Count > 0) Then
Call constraint_everything(temp)
Else
End If
Next
Else
End If
End Sub
here the line
Set constraint1 = constraints1.AddMonoEltCst(catCstTypeReference, ref)
should create constraint with respect to the reference "ref"
but it is not creating it.
This represents the structure which i have to constrain:
Thanks.
Related
i don't know why my code prints an error like "Object required" in line stpos = ARange.End
Public Function CreateNewWordDocument(TempPath)
Dim wd
Set App = CreateObject("Word.Application")
App.Visible = True
Set wd = App.Documents.Add(TempPath)
Set CreateNewWordDocument = wd
End Function
Public Function AddNewParagraphRange(ARange)
Dim NewParagraph
Dim NewRange
Dim I As Integer
I = ARange.Paragraphs.Count
ARange.InsertParagraphAfter
Set NewRange = ARange.Paragraphs(I).Range
NewRange.StartOf wdWord, wdMove
Set AddNewParagraphRange = NewRange
End Function
Public Sub RunForword(CurDBPath)
Dim R As Range
Set R = doc.Range
Dim aPart1
Dim aPart2
Dim aPart3
Set aPart1 = AddNewParagraphRange(R)
Set aPart2 = AddNewParagraphRange(R)
Set aPart3 = AddNewParagraphRange(R)
End Sub
Public Function WriteParagraphLn(ARange, text, StyleName) As Range
Dim stpos As Long
stpos = ARange.End
If Len(ARange) <= 2 Then
ARange.InsertAfter text
Else
ARange.InsertParagraphAfter
ARange.Document.Range(ARange.End, ARange.End + 1).Style = wdNormalStyleName
ARange.InsertAfter text
End If
If StyleName <> "" Then _
ARange.Document.Range(stpos, ARange.End).Style = StyleName
Set WriteParagraphLn = ARange.Document.Range(stpos, ARange.End)
End Function
Sub Creat_doc()
Dim TempPath As String
Dim doc
Set doc = CreateNewWordDocument(TempPath)
With doc
.PageSetup.TopMargin = CentimetersToPoints(2)
.PageSetup.BottomMargin = CentimetersToPoints(1.5)
End With
doc.Activate
Dim TextLine As String
TextLine = WriteParagraphLn("", "hello world", "Times New Roman")
doc.TypeText text:=TextLine
End Sub
After a recent Outlook update, this code started returning
"Compile Error:Argument Not Optional"
The line Set Travel = Items.Add is triggering the error.
Public Sub AddTravelTime()
Dim coll As VBA.Collection
Dim obj As Object
Dim Appt As Outlook.AppointmentItem
Dim Travel As Outlook.AppointmentItem
Dim Items As Outlook.Items
Dim Before&, After&
Dim Category$, Subject$
'1. Block minutes before and after the appointment
Before = 30
After = 30
'3. Assign this category
Category = "Meeting Cushion Time"
Set coll = GetCurrentItems
If coll.Count = 0 Then Exit Sub
For Each obj In coll
If TypeOf obj Is Outlook.AppointmentItem Then
Set Appt = obj
If TypeOf Appt.Parent Is Outlook.AppointmentItem Then
Set Items = Appt.Parent.Parent.Items
Else
Set Items = Appt.Parent.Items
End If
'4. Use the main appointment's subject
Subject = "Meeting Cushion Time"
If Before > 0 Then
Set Travel = Items.Add ' <------ Compile Error
Travel.Subject = Subject
Travel.Start = DateAdd("n", -Before, Appt.Start)
Travel.Duration = Before
Travel.Categories = Category
Travel.Save
End If
If After > 0 Then
Set Travel = Items.Add
Travel.Subject = Subject
Travel.Start = Appt.End
Travel.Duration = After
Travel.Categories = Category
Travel.Save
End If
End If
Next
End Sub
Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
Dim coll As VBA.Collection
Dim Win As Object
Dim Sel As Outlook.Selection
Dim obj As Object
Dim i&
Set coll = New VBA.Collection
Set Win = Application.ActiveWindow
If TypeOf Win Is Outlook.Inspector Then
IsInspector = True
coll.Add Win.CurrentItem
Else
IsInspector = False
Set Sel = Win.Selection
If Not Sel Is Nothing Then
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
End If
Set GetCurrentItems = coll
End Function
The goal is to add a time buffer before and after each meeting.
The travel object is defined as an instance of the AppointmentItem class:
Dim Travel As Outlook.AppointmentItem
But in the code, you are trying to set another item type:
Set Travel = Items.Add
The default item type for a folder will be returned. Of course, it depends on the folder. But I suspect it is not an appointment item in your case.
If "Items.Add" is asking for more arguments, the implication is the items in that collection have more non-optional arguments, so the default items for that folder are not appointment items.
Option Explicit
Public Sub AddTravelTime()
Dim coll As VBA.Collection
Dim obj As Object
Dim Appt As AppointmentItem
Dim Travel As AppointmentItem
Dim Items As Items
Dim Before As Long
Dim After As Long
Dim Subject As String
' Block minutes before and after the appointment
Before = 30
After = 30
Set coll = GetCurrentItems
If coll.Count = 0 Then Exit Sub
For Each obj In coll
If TypeOf obj Is outlook.AppointmentItem Then
Set Appt = obj
Debug.Print "Appt.Subject: " & Appt.Subject
'https://learn.microsoft.com/en-us/office/vba/api/outlook.folder.defaultitemtype
'https://learn.microsoft.com/en-us/office/vba/api/outlook.olitemtype
If TypeOf Appt.Parent Is outlook.AppointmentItem Then
' recurring appointment
Debug.Print "Appt.Parent.Parent: " & Appt.Parent.Parent
Debug.Print Appt.Parent.Parent.DefaultItemType ' 1 = olAppointmentItem
If Appt.Parent.Parent.DefaultItemType = olAppointmentItem Then
Set Items = Appt.Parent.Parent.Items
Else
Debug.Print Appt.Parent.Parent.DefaultItemType
MsgBox "Default item in " & Appt.Parent.Parent & " is not appointment item."
Exit Sub
End If
Else
Debug.Print "Appt.Parent: " & Appt.Parent
Debug.Print Appt.Parent.DefaultItemType ' 1 = olAppointmentItem
If Appt.Parent.DefaultItemType = olAppointmentItem Then
Set Items = Appt.Parent.Items
Else
Debug.Print Appt.Parent.DefaultItemType
MsgBox "Default item in " & Appt.Parent & " is not appointment item."
Exit Sub
End If
End If
Subject = "Meeting Cushion Time"
If Before > 0 Then
Set Travel = Items.Add
Travel.Subject = Subject
Travel.Start = DateAdd("n", -Before, Appt.Start)
Travel.Duration = Before
Travel.Save
End If
If After > 0 Then
Set Travel = Items.Add
Travel.Subject = Subject
Travel.Start = Appt.End
Travel.Duration = After
Travel.Save
End If
End If
Next
End Sub
Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
Dim coll As VBA.Collection
Dim Win As Object
Dim Sel As Selection
Dim obj As Object
Dim i As Long
Set coll = New VBA.Collection
Set Win = ActiveWindow
If TypeOf Win Is outlook.Inspector Then
IsInspector = True
coll.Add Win.CurrentItem
Else
IsInspector = False
Set Sel = Win.Selection
If Not Sel Is Nothing Then
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
End If
Set GetCurrentItems = coll
End Function
I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub
I've recently found out the way below to select the desired TAB (when within a sales order, for instance).
For T = 0 To 15
If Len(T) = 1 Then T = "0" & T
If SapSession.findById("wnd[0]/usr/tabsTAXI_TABSTRIP_HEAD/tabpT\" & T).Text = "Sales" Then
SapSession.findById("wnd[0]/usr/tabsTAXI_TABSTRIP_HEAD/tabpT\" & T).Select
Exit For
End If
Next T
I am looking now for a similar way to loop through the fields in the current active window in order to select (setfocus) on a specific field.
Is it possible?
I found this piece of code at SAP community site and it works fine.
Sub ScanFields(Area As Object, Application As SAPFEWSELib.GuiApplication)
Dim Children As Object
Dim i As Integer
Dim Obj As Object
Dim ObjChildren As Object
Dim NextArea As Object
Set Children = Area.Children()
For i = 0 To Children.Count() - 1
Set Obj = Children(CInt(i))
'If Obj.Type = "GuiTextField" Then 'If Obj.Name = "MyField" Then 'Obj.SetFocus
Debug.Print Obj.Name & " " & Obj.Type & " " & Obj.Text
If Obj.ContainerType() = True Then
Set ObjChildren = Obj.Children()
If ObjChildren.Count() > 0 Then
Set NextArea = Application.FindById(Obj.ID)
ScanFields NextArea, Application
Set NextArea = Nothing
End If
End If
Next i
Set Children = Nothing
End Sub
Sub Test()
Dim SapGuiAuto As Object
Dim Application As SAPFEWSELib.GuiApplication
Dim Connection As SAPFEWSELib.GuiConnection
Dim Session As SAPFEWSELib.GuiSession
Dim UserArea As SAPFEWSELib.GuiUserArea
Set SapGuiAuto = GetObject("SAPGUI")
If Not IsObject(SapGuiAuto) Then
Exit Sub
End If
Set Application = SapGuiAuto.GetScriptingEngine()
If Not IsObject(Application) Then
Exit Sub
End If
Set Connection = Application.Connections(0)
If Not IsObject(Connection) Then
Exit Sub
End If
Set Session = Connection.Sessions(0)
If Not IsObject(Session) Then
Exit Sub
End If
'-Get the user area and scan it recursively-----------------------
Set UserArea = Session.FindById("wnd[0]/usr")
ScanFields UserArea, Application
Set UserArea = Nothing
End Sub
Hey everyone I found this awesome code that helped me get the loop I needed but I am trying to alter this to extract all the data from the word tables not just one row of the tables.. Any help would be great. I know it going to be a simple fix just haven't been able to get any to work on my own. Thanks
Sub wordScrape()
Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files
x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
'sh1.Cells(x, 3) = ....more extracted data....
x = x + 1
wrdDoc.Close
End If
Next wd
wordApp.Quit
End Sub`
Sub wordScrape()
Dim wd As New Word.Application
Dim wdDoc As Word.Document
Dim tbl As Word.Table
Dim sh1 As Worksheet
Dim x As Integer
Dim y As Integer
Dim s As String
Dim r As Range
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set r = sh1.Range("a1")
s = Dir(FolderName & "\*.doc*")
Do While s <> ""
If InStr(wd, "~") = 0 Then
Set wdDoc = wd.Documents.Open(FolderName & "\" & s, False, True, False)
For Each tbl In wdDoc.Tables
For x = 1 To t.Rows.Count
r = wdDoc.Name
For y = 1 To t.Columns.Count
r.Offset(0, y) = Application.WorksheetFunction.Clean(t.Cell(Row:=x, Column:=y).Range)
Next y
Set r = r.Offset(1, 0)
Next x
Next tbl
wdDoc.Close False
End If
s = Dir()
Loop
End Sub
Now, this is off the top of my head, it assumes a reference to word is set (tools,references in the VBE) and it crucially assumes that every table has no merged cells - if they do it will break. But it gets you started