AGENDADOR NO SYSTRAY

DebugStartuoOption is an invlid key.
C:\TestesVB\Mineiro\Project1.VBP canÂÂÂ't de loaded.

Private Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uId As Long
    uFlags As Long
    ucallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Dim t As NOTIFYICONDATA

'=====================================================================
'=====================================================================
'=========================( Código Inserido )=========================
'=====================================================================
'=====================================================================

Private mEnabled As Boolean
Private mInterval As Long
Private mStart As Long
Private mName As String
Private mElapsed As Long

Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Property Get Enabled() As Boolean
 Enabled = mEnabled
End Property

Public Property Let Enabled(ByVal vEnabled As Boolean)
 mStart = 0
End Property

Public Property Get Interval() As Long
 Interval = mInterval
End Property

Public Property Let Interval(vInterval As Long)
  If vInterval > 0 Then
    mStart = 0
    mInterval = vInterval
  Else
    mInterval = 0
    mStart = 0
  End If
End Property


'=====================================================================
'===========================(   F I M   )=============================
'=====================================================================

Private Sub cmdCancelar_Click()
Data1.Recordset.CancelUpdate
Frame1.Enabled = False
cmdFechar.Enabled = True
cmdSalvar.Enabled = False
cmdCancelar.Enabled = False
cmdPesquisar.Enabled = True
cmdExcluir.Enabled = True
End Sub

Private Sub cmdExcluir_Click()
If MsgBox("Deseja excluir permanentemente este registro?", vbYesNo + vbQuestion, Me.Caption) = vbNo Then Exit Sub
If Data1.Recordset.EOF Or Data1.Recordset.BOF Then
MsgBox "Não há mais registros!", vbInformation, Me.Caption
cmdExcluir.Enabled = False
Else
Data1.Recordset.Delete
Data1.Recordset.MoveNext
End If
cmdLancarLPM.Enabled = False
End Sub

Private Sub cmdFechar_Click()

'=====================================================================
'=====================================================================
'=========================( Código Inserido )=========================
'=====================================================================
'=====================================================================
    Enabled = False
'=====================================================================
'===========================(   F I M   )=============================
'=====================================================================

Unload Me
Set frmLembrete = Nothing
End Sub

Private Sub cmdLancarLPM_Click()
Data1.Recordset.Edit
Data1.Recordset.Fields("Atendida") = "ATENDIDA"
Frame1.Enabled = True
cmdFechar.Enabled = False
cmdSalvar.Enabled = True
cmdExcluir.Enabled = False
cmdCancelar.Enabled = True
txtUnidade.SetFocus
End Sub

Private Sub cmdPesquisar_Click()
frmConsulta_01.Show
Me.Enabled = False
End Sub

Private Sub cmdSalvar_Click()
Dim Resp As Byte
Resp = MsgBox("Confirma Gravação da LPM  " & txtLpmNumero & " em Cadastro de LPMs?", vbYesNo + vbQuestion, Me.Caption)
If Resp = 7 Then Exit Sub

Data1.UpdateRecord
'Frame1.Enabled = False
cmdFechar.Enabled = True
cmdExcluir.Enabled = False
cmdSalvar.Enabled = False
cmdPesquisar.Enabled = True
cmdCancelar.Enabled = False
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyReturn Then
    SendKeys "{Tab}"
    KeyCode = 0
  End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
'Função para colocar todas as letras do form. em maiúscula
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub Form_Load()

'Indica o caminho do Banco de Dados e faz a conexao com as tabelas
     Caminho = ReadINI("Caminho", "BD", App.Path & "\CooperNet.ini")
     Set CpnInfo = Workspaces(0).OpenDatabase(Caminho)
     'Set Cliente = CpnInfo.OpenRecordset("CadCliente", dbOpenTable)
     
     Data1.DatabaseName = Caminho
     Data1.RecordSource = "Select * From CadReserva order by Nome"
     Data1.Refresh
     
     Data2.DatabaseName = Caminho
     Data2.RecordSource = "Select * From CadCooperados order by Nome"
     Data2.Refresh
     
     'Habilitaçao dos botões de command
    Frame1.Enabled = False
    cmdSalvar.Enabled = False
    cmdExcluir.Enabled = False
    cmdCancelar.Enabled = False
    'Final de linha
    lblHorario = dataExtenso(Now)
    t.cbSize = Len(t)
    t.hwnd = pichook.hwnd
    t.uId = 1&
    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    t.ucallbackMessage = WM_MOUSEMOVE
    t.hIcon = Me.Icon
    t.szTip = "Exemplo de API Shell_NotifyIcon ..." & Chr$(0) 'Texto a ser exibido quando o mouse é movido sobre o ícone.
    Shell_NotifyIcon NIM_ADD, t
    Me.Hide
    App.TaskVisible = False


'=====================================================================
'=====================================================================
'======================( Código Inserido )=======================
'=====================================================================
'=====================================================================
  
  Enabled = True
  Interval = 1000

  Do While mEnabled
    If mStart = 0 Then mStart = GetTickCount
    mElapsed = GetTickCount
    If (mElapsed - mStart) >= mInterval Then
      mStart = GetTickCount
      Call Ver_Reservas
    End If
    DoEvents
  Loop

'=====================================================================
'===========================(   F I M   )=============================
'=====================================================================

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    t.cbSize = Len(t)
    t.hwnd = pichook.hwnd
    t.uId = 1&
    Shell_NotifyIcon NIM_DELETE, t  'Remove o ícone da barra de tarefas.
End Sub

Private Sub Form_Resize()
    If (Me.WindowState) = 1 Then
        Me.Hide
    End If
End Sub

Private Sub pichook_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'pichook é uma picture box, utilizada pelo Windows para
'reconhecer o ícone na barra de tarefas.
    Static rec As Boolean, msg As Long
    msg = X / Screen.TwipsPerPixelX
    If rec = False Then
        rec = True
        Select Case msg
            Case WM_LBUTTONDBLCLK:
            Case WM_LBUTTONDOWN:
            Case WM_LBUTTONUP:
            Case WM_RBUTTONDBLCLK:
            Case WM_RBUTTONDOWN:
            Case WM_RBUTTONUP:
        'Se for pressionado o botão direito
        'sobre o ícone, é exibido um menu pop-up.
        Me.PopupMenu mnu_taskbar    'mnuBar-menu criado no form.
        End Select
        rec = False
    End If
End Sub

'=====================================================================
'=====================================================================
'=========================( Código Inserido )=========================
'=====================================================================
'=====================================================================


Private Sub Ver_Reservas() '**** Só mudei o nome
On Error GoTo errado

Dim i As Integer
lblHorario = dataExtenso(Now)
DoEvents

Dim DataReservada As Date
Dim TimeAlarme As Date

DataReservada = Data1.Recordset.Fields("DataReservada")
TimeAlarme = Data1.Recordset.Fields("Horario")

If Format$(Hour(Time - TimeAlarme) & ":" & Minute(Time - TimeAlarme) & ":" & Second(Time - TimeAlarme), "hh:mm:ss") = TimeValue("01:00:00") Then
If DataReservada = Date Then
mnu_sobre_Click
txtPesquisa = TimeAlarme
txtPesquisaData = DataReservada
End If
End If

Exit Sub
errado:
Dim Numero_erro As String
Numero_erro = CStr(Err.Number)
If Numero_erro = "3021" Or "13" Then
Else
    MsgBox ("Error # " & CStr(Err.Number) & " " & Err.Description)
    Err.Clear
End If
End Sub
'=====================================================================
'===========================(   F I M   )=============================
'=====================================================================

'=====================================================================
'=====================================================================
'=========================( Código Eliminado )=========================
'=====================================================================
'=====================================================================


'Private Sub Reserva_Timer()
'On Error GoTo errado
'
'Dim i As Integer
'lblHorario = dataExtenso(Now)
'DoEvents
'
'Dim DataReservada As Date
'Dim TimeAlarme As Date
'
'DataReservada = Data1.Recordset.Fields("DataReservada")
'TimeAlarme = Data1.Recordset.Fields("Horario")
'
'If Format$(Hour(Time - TimeAlarme) & ":" & Minute(Time - TimeAlarme) & ":" & Second(Time - TimeAlarme), "hh:mm:ss") = TimeValue("01:00:00") Then
'If DataReservada = Date Then
'mnu_sobre_Click
'txtPesquisa = TimeAlarme
'txtPesquisaData = DataReservada
'End If
'End If
'
'Exit Sub
'errado:
'Dim Numero_erro As String
'Numero_erro = CStr(Err.Number)
'If Numero_erro = "3021" Or "13" Then
'Else
'    MsgBox ("Error # " & CStr(Err.Number) & " " & Err.Description)
'    Err.Clear
'End If
'End Sub


'=====================================================================
'===========================(   F I M   )=============================
'=====================================================================

Private Sub txtPesquisa_Change()
Data1.RecordSource = "Select * From CadReserva where horario like '" & txtPesquisa.Text & "*'"
Data1.Refresh
If Me.Data1.Recordset.RecordCount = 0 Then
MsgBox "Reserva não Cadastrada!", vbInformation, Me.Caption
Unload Me
End If
End Sub

Private Sub txtPesquisaData_Change()
Data1.RecordSource = "Select * From CadReserva where DataReservada like '" & txtPesquisaData.Text & "*'"
Data1.Refresh
If Me.Data1.Recordset.RecordCount = 0 Then
MsgBox "Reserva não Cadastrada!", vbInformation, Me.Caption
Unload Me
End If
End Sub

Private Sub txtUnidade_GotFocus()
'selecionar o texto ao receber o foco
    With txtUnidade
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub

Private Sub txtUnidade_KeyPress(KeyAscii As Integer)
'so permite valores numericos
    Select Case KeyAscii
         Case 8, 48 To 57
           'ok
         Case Else
           KeyAscii = 0
    End Select
End Sub

Private Sub txtUnidade_LostFocus()
If txtUnidade.Text = "" Then
txtUnidade.Text = ""
Exit Sub
End If

Dim StrSql As String
StrSql = "Select * from CadCooperados where Unidade = '" & Format(Me.txtUnidade.Text, "00") & "'"

Me.Data2.RecordSource = StrSql
Me.Data2.Refresh

If Me.Data2.Recordset.RecordCount = 0 Then
MsgBox "Unidade não Cadastrada!", vbInformation, Me.Caption
Else
Me.txtCooperado = Me.Data2.Recordset.Nome
Me.txtVeiculo = Me.Data2.Recordset.VeiculoModelo
End If
End Sub

Private Sub mnu_sobre_Click()
    Me.WindowState = 0
    Me.Show
End Sub

Private Sub mnusair_Click()
    Unload Me
    End
End Sub

Citação:

WEBMASTER escreveu:
O problema seu é que o timer não está funcionando, é isso ????