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
Related
I'm investigating how to automatically update a visio file created with one mastershape (v1.0.vssx) to the next version of the mastershape (v1.1.vssx). When updating each master shape, use Master.Name as the key.
With the code below, I was able to open the vsdx file and vssx and open their respective Masters.
vssx_Master = vssxMaster
vsdx_shape.master = vssx_Master
I wondered if I could update the master shape with the code, but unfortunately vssxMaster is the same as vssxMaster.Name and its type is String.
Is there a way to replace the Master of one shape with another?
not work...
Sub Visio_Update(ByRef VISIOpath As String, ByRef except_sheets() As String, ByRef VSSXpath As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim vsoApp As Visio.Application
Dim vsoDoc As Visio.Document
Dim vsoPage As Visio.Page
Dim vsoItemsCnt As Long
Dim vsoShape As Visio.Shape
Dim FileName As String
Dim FileText As String
FileName = Dir(VISIOpath)
FileName = Replace(FileName, ".vsdx", "")
ChDir ThisWorkbook.path
Set vsoApp = CreateObject("Visio.Application")
Call vsoApp.Documents.OpenEx(VISIOpath, visOpenRW)
Set vsoDoc = vsoApp.Documents.Item(1)
vsoItemsCnt = vsoApp.Documents.Count
Call vsoApp.Documents.OpenEx(VSSXpath, visOpenRW)
Set vssxDoc = vsoApp.Documents.Item(vsoItemsCnt + 1)
Set vssxMasters = vssxDoc.Masters
For Each vsoPage In vsoDoc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
On Error Resume Next
mastername = vsoShape.Master.Name
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
If Err.Number = 0 Then
Debug.Print ("Masters.Item")
Debug.Print "updated succeeded : ", mastername
Err.Clear
Else
Debug.Print ("Masters.Item")
Debug.Print Err.Description
Err.Clear
End If
End If
Next
Next
vsoDoc.SaveAs ThisWorkbook.path & "\data\" & FileName & "_updated_.vsdx"
Application.ScreenUpdating = True
End Sub
Sub test()
choosed_path = "C:\Users\11665307\Desktop\data\vs1.vsdx"
Update_Template = "C:\Users\11665307\Documents\test.vssx"
Call Visio_Update(choosed_path, except_sheets, (Update_Template))
End Sub
I wondered if I could update the master shape with the code
You dont need iterate all masters into stencil :)
For Each vsoPage In doc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
End If
Next
Next
You must iterate through all the shapes on the page. If the shape was created based on the master from stencil v.1.0, then replace it with the corresponding master v.1.1. using the ReplaceShape method
Sub ttt()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.Master.NameU = "Circle" Then sh.ReplaceShape Application.Documents.Item("BLOCK_M.vssx").Masters.ItemU("Diamond")
Next
End Sub
I have some outlook VBA code which works fine to save attachments, however every time I get an email or a meeting notification in Outlook it causes an instant Out of Bounds error If I don't get any emails or notifications the code will run fine through to completion.
Is there a way to ensure that these notifications will not stop the code from running?
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF2_ForNext()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
Dim i As Long
Dim j As Long
saveToFolder = "c:\dev\outlookexport" 'change the path accordingly
savedFileCountPDF = 0
For i = 1 To ActiveExplorer.Selection.Count
Set currentItem = ActiveExplorer.Selection(i)
For j = 1 To currentItem.Attachments.Count
Set currentAttachment = currentItem.Attachments(j)
If UCase(Right(currentAttachment.DisplayName, 5)) = UCase(".xlsx") Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 5) & ".xlsx"
savedFileCountPDF = savedFileCountPDF + 1
End If
' If For Next does not release memory automatically then
' uncomment to see if this has an impact
'Set currentAttachment = Nothing
Next
' If For Next does not release memory automatically then
' uncomment to see if this has an impact
'Set currentItem = Nothing
Next
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
This is what I tried to create from the answer below:
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF2_ForNext()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
Dim i As Long
Dim j As Long
Dim x As Long
Dim myOlExp As Object
Dim myOlSel As Object
' New
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
saveToFolder = "c:\dev\outlookexport" 'change the path accordingly
savedFileCountPDF = 0
For x = 1 To myOlSel.Count
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
Set currentItem = ActiveExplorer.Selection(i)
For j = 1 To currentItem.Attachments.Count
Set currentAttachment = currentItem.Attachments(j)
If UCase(Right(currentAttachment.DisplayName, 5)) = UCase(".xlsx") Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 5) & ".xlsx"
savedFileCountPDF = savedFileCountPDF + 1
End If
Next
End If
Next
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
The Selection property of the Explorer class returns a Selection object that contains the item or items that are selected in the explorer window. In your code I've noticed the following lines of code:
For i = 1 To ActiveExplorer.Selection.Count
Set currentItem = ActiveExplorer.Selection(i)
So, if the selection is changed in Outlook between these two lines of code you may get out of range exception at runtime. Instead, I'd recommend caching the selection object and use it through the code to make sure it remains the same:
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
' do something here
End If
Next
Another important thing is that a folder may contain different types of items. You'd need to check their message class to distinguish different kind of Outlook items.
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
Whenever I receive meeting cancellation, I would like to remove the meeting cancellation request from my inbox and remove the meeting from the Calendar. Below code works for removing the email, but does not remove the meeting. I have to manually go to calendar and click on "Remove from Calendar". Any ideas?
Sub RemoveCancelledMeetingEmails()
Dim objInbox As Outlook.Folder
Dim objInboxItems As Outlook.Items
Dim i As Long
Set objInbox = Application.Session.GetDefaultFolder(olFolderInbox)
For Each Item In objInbox.Items
If TypeOf Item Is Outlook.MeetingItem Then
Dim objMeeting As Outlook.MeetingItem: Set objMeeting = Item
If objMeeting.Class = 54 Then
Dim objAppointment As Outlook.AppointmentItem
'Set objAppointment = objMeeting.GetAssociatedAppointment(True)
'objMeeting.Display
objMeeting.Delete
'Item.Delete
End If
End If
Next
End Sub
Uncommment the GetAssociatedAppointment line (change the parameter to false to avoid creating an appointment if it does not exist) and call objAppointment.Delete
Set olResCalendar = OpenMAPIFolder("\MailboxName\Calendar")
Sub RemoveCanceledAppointments()
Dim olResCalendar As Outlook.MAPIFolder, olApptItem As Outlook.AppointmentItem,
intCounter As Integer
'Change the path to the resource calendar on the next line
Set olResCalendar = OpenMAPIFolder("\MailboxName\Calendar")
For intCounter = olResCalendar.Items.Count To 1 Step -1
Set olApptItem = olResCalendar.Items(intCounter)
If Left(olApptItem.Subject, 9) = "Canceled:" Then
olApptItem.Delete
End If
Next
Set olApptItem = Nothing
Set olResCalendar = Nothing
End Sub
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, i
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath <> ""
i = InStr(szPath, "\")
If i Then
szDir = Left(szPath, i - 1)
szPath = Mid(szPath, i + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function
Function IsNothing(Obj)
If TypeName(Obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function
From: https://superuser.com/questions/663992/how-can-i-set-outlook-2010-to-automatically-remove-cancelled-meeting
Sharing the code that works now.
Sub deleteFromInbox()
Dim oMeetingItem As Outlook.MeetingItem
Dim oAppointmentItem As AppointmentItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItems = oInbox.Items.Restrict("[MessageClass] = 'IPM.Schedule.Meeting.Canceled'")
For Each oAppt In oItems
If TypeOf oAppt Is MeetingItem Then
Set oMeetingItem = oAppt
If Len(oAppt.Subject) > 0 And InStr(1, oAppt.Subject, "Canceled:") <> 0 Then
Set oAppointmentItem = oMeetingItem.GetAssociatedAppointment(False)
Debug.Print oAppt.Subject
If Not oAppointmentItem Is Nothing Then
oAppointmentItem.Delete
End If
oAppt.Delete
End If
End If
Next
End Sub
How could I, using "ReadProcessMemory" API, loop through all running processes of the machine and scan for an Array of strings and return a true/false value if any one or more are contained in the memory of the process - using VB6?
Example:
Strings() = {"#STRING1#", "#ANOTHERSTRING#", "$TRING"}
Loop # Processes
If InStr(ProcessMemory(#), Strings) Then
MsgBox(Process(#) & " Contains one of the strings!")
End If
Loop
i dont know but i used wmi in my program
something how that
Public Sub KillProcess(ByVal processName As String)
On Error GoTo ErrHandler
Dim oWMI
Dim ret
Dim sService
Dim oWMIServices
Dim oWMIService
Dim oServices
Dim oService
Dim servicename
Set oWMI = GetObject("winmgmts:")
Set oServices = oWMI.InstancesOf("win32_process")
For Each oService In oServices
servicename = LCase$(Trim$(CStr(oService.Name) & ""))
If InStr(1, servicename, LCase(processName), vbTextCompare) > 0 Then
ret = oService.Terminate
End If
Next
If Not oServices Is Nothing Then Set oServices = Nothing
If Not oWMI Is Nothing Then Set oWMI = Nothing
ErrHandler:
Err.Clear
End Sub