kamera ile mesaiye girme

esad45 · 1 Ekim 2013

işletmemizde kamera ile mesaiye girmek istiyoruz bu excel de münkün mü? butona tıkladığımda bilgisayarıma bağlı kamera çalışssın ve kaydete tıkladığımda mesai sayfasına fotoğrafımla birlikte o ank tarih ve saat yazsın olabilir mi ek te anlatmaya çalıştım

Murat OSMA · 1 Ekim 2013

Resmi de hücreye eklemek ister misiniz ?

esad45 · 1 Ekim 2013

evet mesai kısmında olmalı

Murat OSMA · 2 Ekim 2013

Merhaba Esad Bey,

Mevcut kodları aşağıda görebilirsiniz. Dosyanızı da ekliyorum.

Not: Kodlar Sn. Tarkan VURAL'a aittir. Dosyanıza göre uyarlanmıştır.

Kod:

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
                            ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
                            ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
                            ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" _
                            (ByVal lpszWindowName As String, ByVal dwStyle As Long, _
                            ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
                            ByVal nHeight As Long, ByVal hWndParent As Long, ByVal nID As Long) As Long
Rem Www.ExcelVBA.Net - Tarkan VURAL - 20-06-2012
Const CAP As Long = &H400
Const CAP_DRIVER_CONNECT As Long = CAP + 10
Const CAP_DRIVER_DISCONNECT As Long = CAP + 11
Const CAP_EDIT_COPY As Long = CAP + 30
Const CAP_SET_PREVIEW As Long = CAP + 50
Const CAP_SET_PREVIEWRATE As Long = CAP + 52
Const CAP_SET_SCALE As Long = CAP + 53
    Const WS_CHILD As Long = &H40000000
    Const WS_VISIBLE As Long = &H10000000
    Const SWP_NOMOVE As Long = &H2
    Const SWP_NOSIZE As Long = 1
    Const SWP_NOZORDER As Long = &H4
    Const HWND_BOTTOM As Long = 1
    Dim iDevice As Long
    Dim evn As Long

Private Sub UserForm_Initialize()
Dim iHeight As Long
Dim iWidth As Long
    iHeight = picCapture.Height
    iWidth = picCapture.Width
        evn = capCreateCaptureWindowA(iDevice, WS_VISIBLE Or WS_CHILD, 0, 0, 800, 600, picCapture.hwnd, 0)
        If SendMessage(evn, CAP_DRIVER_CONNECT, iDevice, 0) Then
            Call SendMessage(evn, CAP_SET_SCALE, True, 0)
            Call SendMessage(evn, CAP_SET_PREVIEWRATE, 66, 0)
            Call SendMessage(evn, CAP_SET_PREVIEW, True, 0)
            Call SetWindowPos(evn, HWND_BOTTOM, 0, 0, picCapture.Width, picCapture.Height, _
                                   SWP_NOMOVE Or SWP_NOZORDER)
        Else
            DestroyWindow (evn)
        End If
    End Sub

Private Sub CommandButton1_Click()
Dim sil As ChartObject
Call SendMessage(evn, CAP_EDIT_COPY, 0, 0)
evnresim = "C:\evnresim.jpg"
With ActiveSheet.ChartObjects.Add(0, 0, picCapture.Width, picCapture.Height).Chart
    .Paste
    .Export evnresim
    For Each sil In ActiveSheet.ChartObjects
        sil.Delete
    Next sil
    Image1.Picture = LoadPicture(evnresim)
    Sayfa1.Range("C6").Copy
    With Sayfa3
        .Range("B65536").End(3)(2, 1).PasteSpecial xlPasteValues
        .Range("C65536").End(3)(2, 1) = VBA.Now: .Select
        ActiveSheet.Pictures.Insert(evnresim).Select
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.ShapeRange.Top = .Range("C65536").End(3).Top
        Selection.ShapeRange.Left = .Range("d65536").End(3).Left
        Selection.ShapeRange.Height = .Range("c65536").End(3).Height
        Selection.ShapeRange.Width = .Range("d65536").End(3)(2, 1).Width
    End With
   Kill evnresim
End With
Application.CutCopyMode = False
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call SendMessage(evn, CAP_DRIVER_DISCONNECT, iDevice, 0)
DestroyWindow (evn)
End Sub

esad45 · 2 Ekim 2013

dosyada denedim çalışmıyor automotion error veriyor

Zeki Gürsoy · 2 Ekim 2013

Merhaba,

Örneğin çalışabilmesi için "hWnd", "hDC" vs. özellikleri barınan activex denetimi (picturebox) gerekli.

esad45 · 2 Ekim 2013

nasıl yani anlamadım

Zeki Gürsoy' Alıntı:
Merhaba,

Örneğin çalışabilmesi için "hWnd", "hDC" vs. özellikleri barınan activex denetimi (picturebox) gerekli.

nasıl yani anlamadım

Zeki Gürsoy · 2 Ekim 2013

Yani, "capCreateCaptureWindowA" isimli API nin görüntüyü verebileceği nesne gerekli.

Zeki Gürsoy · 2 Ekim 2013

Küçük bir revizyon ile deneme yaptım; direkt olarak userform arka planı da olabiliyor. Aşağıdaki kodu test edin.

Kod:

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
                            ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
                            ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" _
                            (ByVal lpszWindowName As String, ByVal dwStyle As Long, _
                            ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
                            ByVal nHeight As Long, ByVal hWndParent As Long, ByVal nID As Long) As Long

[B]Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                            ByVal lpClassName As String, ByVal lpWindowName As String) As Long
[/B]
Rem Www.ExcelVBA.Net - Tarkan VURAL - 20-06-2012
Const CAP As Long = &H400
Const CAP_DRIVER_CONNECT As Long = CAP + 10
Const CAP_DRIVER_DISCONNECT As Long = CAP + 11
Const CAP_EDIT_COPY As Long = CAP + 30
Const CAP_SET_PREVIEW As Long = CAP + 50
Const CAP_SET_PREVIEWRATE As Long = CAP + 52
Const CAP_SET_SCALE As Long = CAP + 53
    Const WS_CHILD As Long = &H40000000
    Const WS_VISIBLE As Long = &H10000000
    Const SWP_NOMOVE As Long = &H2
    Const SWP_NOSIZE As Long = 1
    Const SWP_NOZORDER As Long = &H4
    Const HWND_BOTTOM As Long = 1
    Dim iDevice As Long
    Dim evn As Long

Private Sub UserForm_Activate()
[B]www = FindWindow(vbNullString, Me.Caption)[/B]

Dim iHeight As Long
Dim iWidth As Long
    [B]iHeight = Me.Height
    iWidth = Me.Width[/B]
        evn = capCreateCaptureWindowA(iDevice, WS_VISIBLE Or WS_CHILD, 0, 0, 800, 600, [B]www[/B], 0)
        If SendMessage(evn, CAP_DRIVER_CONNECT, iDevice, 0) Then
            Call SendMessage(evn, CAP_SET_SCALE, True, 0)
            Call SendMessage(evn, CAP_SET_PREVIEWRATE, 66, 0)
            Call SendMessage(evn, CAP_SET_PREVIEW, True, 0)
            Call SetWindowPos(evn, HWND_BOTTOM, 0, 0, [B]Me.Width, Me.Height[/B], _
                                   SWP_NOMOVE Or SWP_NOZORDER)
        Else
            DestroyWindow (evn)
        End If

End Sub

Private Sub CommandButton1_Click()
Dim sil As ChartObject
Call SendMessage(evn, CAP_EDIT_COPY, 0, 0)
evnresim = "C:\evnresim.jpg"
With ActiveSheet.ChartObjects.Add(0, 0, picCapture.Width, picCapture.Height).Chart
    .Paste
    .Export evnresim
    For Each sil In ActiveSheet.ChartObjects
        sil.Delete
    Next sil
    Image1.Picture = LoadPicture(evnresim)
    Sayfa1.Range("C6").Copy
    With Sayfa3
        .Range("B65536").End(3)(2, 1).PasteSpecial xlPasteValues
        .Range("C65536").End(3)(2, 1) = VBA.Now: .Select
        ActiveSheet.Pictures.Insert(evnresim).Select
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.ShapeRange.Top = .Range("C65536").End(3).Top
        Selection.ShapeRange.Left = .Range("d65536").End(3).Left
        Selection.ShapeRange.Height = .Range("c65536").End(3).Height
        Selection.ShapeRange.Width = .Range("d65536").End(3)(2, 1).Width
    End With
   Kill evnresim
End With
Application.CutCopyMode = False
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call SendMessage(evn, CAP_DRIVER_DISCONNECT, iDevice, 0)
DestroyWindow (evn)
End Sub

Murat OSMA · 2 Ekim 2013

Aslında UserForm üzerinde 1 adet ListView, 1 adet Image ve 1 adet CommandButton olması yeterlidir.

Sanırım hata vermesinin nedeni: mscomctl.ocx nesnesinin ilgili bilgisayarda düzgün çalışmaması. İlgili ocx'i unregister edip tekrar register ederek bir deneyin.

Not: Mesajı düzenleyip görsel ekledim.

esad45 · 2 Ekim 2013

ben bir tüğrlü anlamadım ekli dosya da bunu yapabilirmisiniz

esad45 · 2 Ekim 2013

sayın murat bey,

gönderdiğiniz ekli dosya ilk sefer çalıştı ama şimdi ikinci çalıştırmada kameraya bağlanmıyor

Murat OSMA · 3 Ekim 2013

Bilmiyorum Esad Bey, dosyayı defalarca denedim bir sorun yok.
Dosyayı kapatıp tekrar açın ya da tekrar indirip deneyin olmazsa yarın tekrar bakarım.

esad45 · 3 Ekim 2013

murat bey tamam şimdi çalışıyor

Murat OSMA' Alıntı:
Bilmiyorum Esad Bey, dosyayı defalarca denedim bir sorun yok.
Dosyayı kapatıp tekrar açın ya da tekrar indirip deneyin olmazsa yarın tekrar bakarım.

Murat bey ben dosyada bir kaç görsel değişiklik yaptım bununla beraber foto ekle bölümü koydum o personelin ismi seçilince resimler klosörünün altında personel dosyasında o personel adında resim ekledim isim değişince personelin de fotosu değişir mi böyle bir makro yapmak istedim bir bakarsanız sevinirim
birde mesai dosyasına yapıştırıyor ya o dosyayı gizlemeli ve o dosya gizli kalmalı zira personel oraya erişip bilgilerini değiştirmememli bunu da yapabilirmiyiz

esad45 · 3 Ekim 2013

birde dosya kapatılıp açılınca resimleri siliyor mesai dosyassındaki "resim taşınmış yada ad değiştirilmiş falan diyor)

Murat OSMA · 3 Ekim 2013

esad45' Alıntı:
birde dosya kapatılıp açılınca resimleri siliyor mesai dosyassındaki "resim taşınmış yada ad değiştirilmiş falan diyor)

Çünkü; resmi sayfaya ekledikten sonra Kill evnresim satırıyla resmi siliyoruz.

Dosya ile sayfa kavramını karıştırmamalısınız, bu bizi yanıltır ve konuyu uzatmamıza sebep olur.
Mesai sayfasını gizlemek için; önce sayfayı gizleyin sonra da sitede Activesheet.protect ya da Activesheet.unprotect yazıp aratın. Bulduğunuz kodları CommandButton kodları içerisinde ilgili yerlerine yapıştırın.
Resim çağırma ile ilgili olarak; kaç personel varsa resimlerini çekip klasöre kaydedin sonra isim eşleştirmesiyle tekrar çağrılabilir. Resim çağırmak için her çekilen resmi bir klasöre kaydetmek bence gereksiz.

esad45 · 4 Ekim 2013

eklemelerde yapıldı

eklemelerde yaptım ama benim istediğim fotoğrafın orda olması kapatılıp atekrar açılınca foto ek teki gibi oluyor ve mesai sayfası işlem bitince gizlenmesi yada şifrelenmesi lazım onu bir türlü yapamadım bakabilrmisiniz ek teki dosyama

esad45 · 5 Ekim 2013

cevap verecek yok mu

Murat OSMA · 6 Ekim 2013

Önceki mesajımda resmin neden silindiğin yazmıştım. Bu konuda hiçbir şey yapmadınız sanırım.

Sitenin üst bölümündeki Arama kısmına;
sayfa gizleme
sayfa şifreleme
gibi kelimeler yazarak gerekli bilgiye ulaşabilirsiniz..

esad45 · 6 Ekim 2013

kilit açma ve kapama

murat bey aradım buldum yaptım lakin olmadı makro hata verdi birde remin silinmeisni ben istemiyorum om zaman reimle mesai girmenin ne anlamı olablir ki mesaiye başkası da girebiliri yerine nasıl olsa resim siliniyor

kamera ile mesaiye girme

esad45

Ekli dosyalar

Murat OSMA

Altın Üye

esad45

Murat OSMA

Altın Üye

Ekli dosyalar

esad45

Zeki Gürsoy

Uzman

esad45

Zeki Gürsoy

Uzman

Zeki Gürsoy

Uzman

Murat OSMA

Altın Üye

Ekli dosyalar

esad45

esad45

Murat OSMA

Altın Üye

esad45

Ekli dosyalar

esad45

Murat OSMA

Altın Üye

esad45

Ekli dosyalar

esad45

Murat OSMA

Altın Üye

esad45