Excel 2007 de Programsız Fotoğraf Çekmek

Excel konusundaki ufak ama önemli püf noktalara buradan ulaşabilirsiniz

Cevap: Excel 2007 de Programsız Fotoğraf Çekmek

İleti#21)  tayfuny » 17 Ekm 2016 16:51

Konu eski ama form üzerinde oynattığım videolardan ekran görüntüsü almak için kullanıyordum.

Kod: Tümünü seç
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

'Public Const VK_SNAPSHOT = &H2C
'Public Const VK_SNAPSHOT = 44
'Public Const VK_LMENU = 164
'Public Const KEYEVENTF_KEYUP = 2
'Public Const KEYEVENTF_EXTENDEDKEY = 1


'Declare Virtual Key Codes
Private Const VK_SNAPSHOT = &H2C
Private Const VK_KEYUP = &H2
Private Const VK_MENU = &H12
Public Const VK_TAB = &H9
Public Const VK_ENTER = &HD


Sub ScreenPrint() 
  Application.ScreenUpdating = False
   'Press Alt + TAB Keys -- Step1
    Alt_Tab
    'Press Print Screen key using Windows API -- Step2.
   'Application.Wait Now + TimeValue("00:00:01")
   keybd_event VK_SNAPSHOT, 1, 0, 0 'Print Screen key down
   keybd_event VK_SNAPSHOT, 1, VK_KEYUP, 0 'Print key Up - Screenshot to Clipboard
   Application.Wait Now + TimeValue("00:00:01")
  '  On Error GoTo NoCrop:
    Sheets("Snap").Select
    Sheets("Snap").Range("A1").Select
    Sheets("Snap").Paste
    Sheets("Snap").Shapes(1).PictureFormat.CropBottom = 133
    Sheets("Snap").Shapes(1).PictureFormat.CropRight = 97
    Sheets("Snap").Shapes(1).PictureFormat.CropLeft = 25
    Sheets("Snap").Shapes(1).PictureFormat.CropTop = 83
   
    Sheets("Snap").Shapes(1).IncrementTop -100
    Sheets("Snap").Shapes(1).IncrementLeft -50
   
    Sheets("Snap").Shapes(1).CopyPicture Excel.XlPictureAppearance.xlScreen, Excel.XlCopyPictureFormat.xlPicture
   pc1 = Sheets("Snap").Range("aa1").Value
   Sheets("Snap").Range("aa1").Value = pc1 + 1
   pic = "picture" & Sheets("Snap").Range("aa1").Value & ".jpg"
     
   Application.DisplayAlerts = False
        Set tmp = Charts.Add
        With tmp
            '.SeriesCollection(1).Delete
            .Paste
            .Export Filename:=ActiveWorkbook.Path & "\Export_img\" & pic, FilterName:="jpg"
            .Delete
        End With
   Sheets("Snap").Shapes(1).Delete
  ' Attach_File

NoCrop:
Sheets("Kontrol").Select
Application.ScreenUpdating = True
End Sub


Kod: Tümünü seç
Sub Alt_Tab()
    DoEvents
    keybd_event VK_MENU, 1, 0, 0 'Alt key down
    DoEvents
    keybd_event VK_TAB, 0, 0, 0 'Tab key down
    DoEvents
    keybd_event VK_TAB, 1, VK_KEYUP, 0 'Tab key up
    DoEvents
    keybd_event VK_ENTER, 1, 0, 0 'Tab key down
    DoEvents
    keybd_event VK_ENTER, 1, VK_KEYUP, 0 'Tab key up
    DoEvents
    keybd_event VK_MENU, 1, VK_KEYUP, 0 'Alt key up
    DoEvents
End Sub


Kod: Tümünü seç
Sub Attach_File()
pic = "ClipBoardToPic.jpg"
    ActiveCell.Select
    ActiveSheet.OLEObjects.Add(Filename:=ActiveWorkbook.Path & Application.PathSeparator & pic, Link:=False, _
        DisplayAsIcon:=True, IconFileName:= _
        "C:\Program Files\Internet Explorer\iexplore.exe", IconIndex:=10, IconLabel _
        :="ClipBoardToPic.jpg").Select
End Sub
Kullanıcı avatarı
tayfuny
 
Adı Soyadı:Tayfun Yörü
Kayıt: 22 Haz 2009 11:29
Konum: Sakarya
Meslek: Otomotiv (Planlama)
Yaş: 43
İleti: 8
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Sakarya

Önceki

Forum Excel'in Püf Noktaları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 1 misafir

Bumerang - Yazarkafe