how to take a screenshot for a selected area using vba Catia V5 4

[KABEL]

Hi everybody,

I’m working on project in catia V5 using vba, in this project I want to achieve those things :
I want to use a userform with two buttons:

[ul]
[li]the first one is reserved to appear the Capture toolbox (picture below)

,Then wait for the user to select the area that he want to be captured (using the select mode : picture below).

[/li]
[/ul]

[ul]
[li]The second one will allow the user to take a screenshot for the selected area.(picture bellow)

[/li]
[/ul]

My problem is when I (click on the second button) take a screenshoot (using vba),the captured picture is not focused on the selected area (all the window is included at the picture ).

Any hint is really appreciated
Regards,

 

[KABEL]

Can someone please help me out?

 

[iscariot]

I don't think it is possible to achieve what you need.

 

[catiavbmacro]

Hi, can you use fit all in ? and make this area a little bigger? Can that help?

 

[KABEL]

iscariot
yeah, I've been spending days trying to solve this issue.

catiavbmacro
I want to give the user the possibility to select an area that he desire to be captured, then with the second button I have to take a picture of that area because I'll include this picture in a generated report I've created (with the vba code) (excel file) , you see that's why even the zoom option wont work for me.

 

[ferdo]

What about run Snipping Tool (from Windows) and then Paste the clipboard in Excel?

I suppose you are running the code from a fomm in Excel...

Regards
Fernando

https://picasaweb.google.com/102257836106335725208

- Romania

https://picasaweb.google.com/103462806772634246699/

- EU

 

[KABEL]

Hi ferdo,
thank you, I really appreciate the way you help others ,
using the snipping tool sames to be a good way to solve this problem, that what I did :

Public wsh As Object
   Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
     (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long

   Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
     (ByVal hwnd As Long, ByVal lpString As String, _
     ByVal aint As Long) As Long
   Declare Function GetWindow Lib "user32" _
     (ByVal hwnd As Long, ByVal wCmd As Long) As Long

   Declare Function EnumWindows Lib "user32" _
     (ByVal wndenmprc As Long, ByVal lParam As Long) As Long

   Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
     (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
     lParam As Any) As Long
     
   Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

   Private Const WM_CLOSE = &H10
   Private Const GW_HWNDFIRST = 0
   Private Const GW_HWNDLAST = 1
   Private Const GW_HWNDNEXT = 2
   Private Const GW_HWNDPREV = 3
   Private Const GW_OWNER = 4
   Private Const GW_CHILD = 5
   Private Const GW_MAX = 5
   Private mstrTarget As String
   Private mblnSuccess As Boolean
   
Public Function EnumCallback(ByVal app_hWnd As Long, ByVal param As Long) As Long
   Dim buf As String * 256
   Dim title As String
   Dim length As Long
   ' Checks a returned task to determine if App should be closed
   ' get window's title.
   length = GetWindowText(app_hWnd, buf, Len(buf))
   title = Left$(buf, length)
   ' determine if target window.
   If InStr(UCase(title), UCase(mstrTarget)) <> 0 Then
      ' Kill window.
      SendMessage app_hWnd, WM_CLOSE, 0, 0
      mblnSuccess = True
   End If
   ' continue searching.
   EnumCallback = 1
End Function
   
Public Function blnCloseWindow(strApplicationTitle As String) As Boolean

   ' retrieve Windows list of tasks.
   mblnSuccess = False
   mstrTarget = strApplicationTitle
   EnumWindows AddressOf EnumCallback, 0
   blnCloseWindow = mblnSuccess

End Function

[COLOR=#EF2929]Private Sub CommandButton1_Click()
Set wsh = VBA.CreateObject("WScript.Shell") 
wsh.Run "C:\Windows\sysnative\SnippingTool.exe"
End Sub[/color]

[COLOR=#729FCF]Private Sub CommandButton2_Click()
AppActivate "Outil Capture"
SendKeys "^C"
[COLOR=#73D216]blnCloseWindow "Outil Capture"
Sleep 500
SendKeys "{TAB}"
SendKeys "{ENTER}"[/color]
Dim AppliExcel As Object
Set AppliExcel = CreateObject("Excel.Application") AppliExcel.Workbooks.Add AppliExcel.Visible = True With AppliExcel.ActiveSheet
    .Range("C6:G12").Select
    .Paste
End With

End Sub[/color]

everything works fine except for the green line ,they don't close the snipping tool, Please is there any away to close the snipping tool.
thank you again,
Regards,

 

[ferdo]

Kill the Snipping Windows process (eventually after paste in Excel)?

Regards
Fernando

https://picasaweb.google.com/102257836106335725208

- Romania

https://picasaweb.google.com/103462806772634246699/

- EU

 

[KABEL]

Thank you again Ferdo,

now everything works fine, I found this to way to kill the snipping tool :

Sub TerminateApp()
     '---------------------------------------------------------------------------------------
     ' Terminates the exe process specified.
     ' Uses WMI (Windows Management Instrumentation) to query all running processes
     ' then terminates ALL instances of the exe process held in the variable strTerminateThis.
     '---------------------------------------------------------------------------------------

Dim strTerminateThis As String 
'The variable to hold the process to terminate

Dim objWMIcimv2 As Object, objProcess As Object, objList As Object
Dim intError As Integer

'Process to terminate – you could specify and .exe program name here

strTerminateThis = [COLOR=#EF2929]"bc-wedge.exe"[/color] [COLOR=#73D216]'===> here I specify the app that I want to Kill (in my case: snipping tool)[/color]

'Connect to CIMV2 Namespace and then find the .exe process

Set objWMIcimv2 = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & strTerminateThis & "'")
For Each objProcess In objList
            intError = objProcess.Terminate 'Terminates a process and all of its threads.
             'Return value is 0 for success. Any other number is an error.
            If intError <> 0 Then Exit For
Next

'ALL instances of exe (strTerminateThis) have been terminated
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing

End Sub

yes before closing the snipping tool , I copy the content (image) using the sendkeys "^C" , (ctr+C)

Regards,

 

[ferdo]

Star from me for searching and find a solution.

Regards
Fernando

https://picasaweb.google.com/102257836106335725208

- Romania

https://picasaweb.google.com/103462806772634246699/

- EU

 

[CAD2015]

You can also use Win+Print (Windows 10) keyboard keys...



CAD 2015

 

[ferdo]

This year I will also switch to Win 10 and R27 (for most of the time)....

Regards
Fernando

https://picasaweb.google.com/102257836106335725208

- Romania

https://picasaweb.google.com/103462806772634246699/

- EU

 

[KABEL]

ferdo
I really appreciate your help, thank you veryy much ,
have a nice week end,

hi CAD2015
thank you for the suggestion , unfortunately I'm on win 7 .

 

[CAD2015]

Win 7 has snapping keys as well:
1) Alt+Print
2) Print

Try both of them.

CAD 2015

 

[ferdo]

And here it is the CATIA 3DEXPERIENCE version

I used your TerminateApp sub and my main sub is here

    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'MS Office 64 Bit

Sub Catmain()

'MsgBox "You have 5 sec to grab your screen region"

Set wsh = VBA.CreateObject("WScript.Shell")
wsh.Run "c:\Windows\System32\SnippingTool.exe"

Sleep 5000

Dim FileSys
Set FileSys = CATIA.FileSystem

Dim xlApp
Set xlApp = CreateObject("Excel.Application")

Dim mydoc
Set mydoc = xlApp.Workbooks.Open("c:\temp\Report.xlsx")

xlApp.Visible = True

With xlApp.ActiveSheet
    .Range("C6").Select
    .Paste
End With

TerminateApp

End Sub

Regards
Fernando

https://picasaweb.google.com/102257836106335725208

- Romania

https://picasaweb.google.com/103462806772634246699/

- EU