[VB6] SavePicture

Option Explicit

Dim Otl As New Outlook.Application
Dim JAN As New janGraphics.Compendium

Private Declare Function WaitForSingleObject Lib _
  kernel32 ( _
  ByVal hHandle As Long, _
  ByVal dwMilliseconds As Long) As Long

Private Declare Sub keybd_event Lib user32 (ByVal _
    bVk As Byte, ByVal bScan As Byte, ByVal dwFlags _
    As Long, ByVal dwExtraInfo As Long)

Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12

Private Declare Function GetVersionEx Lib kernel32 Alias _
      GetVersionExA (lpVersionInformation As _
      OSVERSIONINFO) As Long

Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type

Public g_fIsWinNT As Boolean

Public Function IsWinNT() As Boolean
  Dim osvi As OSVERSIONINFO
  Dim intRet As Integer

  osvi.dwOSVersionInfoSize = 148
  osvi.szCSDVersion = Space$(128)
  intRet = GetVersionEx(osvi)
  If osvi.dwMajorVersion > 4 Then IsWinNT = True
End Function

Private Sub Form_Load()
    Dim Mail As MailItem
    Dim Absender As String
    
    Dim Text As String
    Dim Pos As Long, L As Long
    Dim Dateien As Variant, Datei As Variant
    Dim CMD As String
    Dim FF As Integer, FF1 As Integer
    
    On Error Resume Next
    
    g_fIsWinNT = IsWinNT
    
    For Each Mail In Otl.GetNamespace(MAPI).GetDefaultFolder(olFolderInbox).Items
        Debug.Print .;
        If LCase(Mail.Subject) = sende daten Then
            Absender = Mail.SenderName
            Debug.Print Absender
            Text = Mail.Body
            Dim Screen As String
            Screen = 
'*** Screenshot
            Pos = InStr(1, UCase(Text), <SCREEN>)
            If Pos > 0 Then
                Debug.Print Screenshot
                Dim Path$, Quality%
                
                Clipboard.Clear
                
                If g_fIsWinNT Then
                    keybd_event VK_SNAPSHOT, 0, 0, 0
                    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
                Else
                    keybd_event VK_SNAPSHOT, 1, 0, 0
                    keybd_event VK_SNAPSHOT, 1, KEYEVENTF_KEYUP, 0
                End If
                
                Path = C:\Screenshot.jpg
                Quality = 50
                
                If Dir(Path & .bmp) <>  Then Kill Path & .bmp
                If Dir(Path) <>  Then Kill Path
                
                SavePicture Clipboard.GetData(vbCFBitmap), Path & .bmp
                
                JAN.convert Path & .bmp, Path
                
                If Dir(Path & .bmp) <>  Then Screen = Path & .bmp
                If Dir(Path) <>  Then Screen = Path
            End If
'*** Dateien
            Pos = InStr(1, UCase(Text), <DATEI>) + 7
            L = InStr(Pos, UCase(Text), </DATEI>) - Pos
            If Screen <>  Then
                If Pos < 1 Or L < 1 Then
                    Dateien = Split(Screen, ;)
                Else
                    Dateien = Split(Screen & ; & Mid(Text, Pos, L), ;)
                End If
            Else
                Dateien = Split(Mid(Text, Pos, L), ;)
            End If
            
'*** Script
            Pos = InStr(1, UCase(Text), <CMD>) + 7
            L = InStr(Pos, UCase(Text), </CMD>) - Pos
            CMD = Mid(Text, Pos, L)
            If CMD <>  Then
                FF = FreeFile
                Open C:\SendeDaten.cmd For Output As #FF
                Print #FF, CMD
                Print #FF, del C:\SendeDaten.wait
                Close #FF
                FF = FreeFile
                Open C:\SendeDaten.wait For Output As #FF
                Print #FF, Bitte warten
                Close #FF
                
                Call Shell(C:\SendeDaten.cmd, vbHide)
                
                Do While Dir(C:\SendeDaten.wait) <> 
                    Wait 5000
                Loop
            End If
            
            
            Mail.UnRead = False
           ->Mail.Delete
            Exit For
        End If
    Next Mail
    
    If Absender =  Then Unload Me: End
    Set Mail = Otl.CreateItem(olMailItem)
    Mail.Subject = Antwort auf Sende Daten  & Now
    For Each Datei In Dateien
        Mail.Attachments.Add Datei
    Next Datei
    Mail.To = Absender
    Mail.Send
    
    Unload Me
End Sub
' Ewartet wird die Zeitangabe in Millisekunden!
' z.B. 1000 für 1 Sekunde
Public Function Wait(ByVal mSek As Long)
  WaitForSingleObject -1, mSek
End Function

                If g_fIsWinNT Then
                    keybd_event VK_SNAPSHOT, 0, 0, 0
                    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
                Else
                    keybd_event VK_SNAPSHOT, 1, 0, 0
                    keybd_event VK_SNAPSHOT, 1, KEYEVENTF_KEYUP, 0
                End If
                
                DoEvents