dotNETportal.cz

Dobrý den,

mám kalendář, který se spouští klávesovou zkratkou:

Application.OnKey "+^{C}", "Module1.OpenCalendar"

.. jak změním kód aby se kalendář spustil po kliku do buňky naformátované jako "datum"?

Díky

Ve vba excel nabídka událostí:

Worksheet:

BeforeDoubleClick a BeforeRightClick

(pro jednotlivé listy)

Workbook nebo Application:

SheetBeforeDoubleClick a SheetBeforeRightClick

(pro všechny listy v šešitu příp. aplikaci)

Pro události aplikace nutno vytvořit třídu,

příklad naleznete ve vba nápovědě:

Using Events with the Application Object

Např. spuštěni po dvojkliku v události sešitu (ThisWorkbook)

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If IsDate(ActiveCell.Value) Then
        Module1.OpenCalendar
        Cancel = True
    End If
End Sub

Pokud trváte na kliku levým tlačítkem, budete muset zapátrat,

jak to vyřešit, možná pomocí API funkce SwapMouseButton:

http://www.mrexcel.com/forum/showthread....

Další úskalí Vás čeká při zobrazení formuláře,

budete-li ho chtít zobrazit na pozici buňky...

Případně bude možná zajímavé:

http://excelplus.net/forum/viewthread.ph...

Snad také doplněk kalendář tamtéž:

http://excelplus.net/news.php?readmore=6...

Díky za kód funguje to, ALE nejde to na prázdných polích typu DATE pouze to kontroluje value v buňce. Jde i tohle nějak vyřešit?

Na http://excelplus.net/news.php?readmore=6... jsem DatePicker našel již dříve akorát mi tam vadí že se musí pro zavření kliknout na tlačítko. Pokud by někdo věděl jak to upravit aby se automaticky zavřel po výběru dne?

Ještě je pěknej kalenář na http://blogs.msdn.com/excel/archive/2007... ale zase je kód chráněn heslem :-(

... jo ještě jsem zapoměl dodat že zrovna ve Visual Basicu programovat neumím tak prosím pokud možno polopatě :-)

Pro prázdné buňky otestuj jejich formát např.:

'If ActiveCell.NumberFormatLocal="d.m.rrrr" Then
'If ActiveCell.NumberFormat="m/d/yyyy" Then

Pro následné zavření formuláře vyhledej místo

v kódu, kde se předá datum vybrané v kalendáři

aktivní buňce.

Formulář zavřeš pomocí:

Unload Me

If ActiveCell.NumberFormatLocal="d.m.rrrr" Then

..tak tohle mi funguje pokud to zadám přímo do souboru xls. Když jsem to zadal do ThisWorkbooku xla šablony tak to nejde. Co dělám špatně?

Unload Me

... to jak se zavírá form už vím jenže ten kód je na mě trochu složitější (click událost pod tlačítkama dnů tam není). Zkoušel jsem pár míst kam to zadat a vyskočil runtime error....

Tak problém se zavíráním kalendáře vyřešen.

Zbývá vyřešit otevírání dvojklikem s kódem v xla:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If IsDate(ActiveCell.Value) Then
        Module1.OpenCalendar
        Cancel = True
    End If
End Sub

...pokud tohle zadám do ThisWorkbooku xla souboru tak to nefunguje (v xls ano). Co s tím?

Zkuste třídu pro události excel aplikace...

ThisWorkbook:

Option Explicit

Private xlAppEvents As EventsOfApplication

Private Sub Workbook_Open()
    Set xlAppEvents = New EventsOfApplication
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set xlAppEvents = Nothing
End Sub

ClassModule EventsOfApplication:

Option Explicit

Private WithEvents xlApp As Excel.Application

Private Sub Class_Initialize()
    Set xlApp = Application
End Sub

Private Sub Class_Terminate()
    Set xlApp = Nothing
End Sub

Private Sub XlApp_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If IsDate(ActiveCell.Value) Then
        Module1.OpenCalendar
        Cancel = True
    End If
End Sub

Radši uvedu celý kód, některé třídy už jsou použitý hází to chyby:

ThisWorkbook:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.CommandBars("Cell").Reset
End Sub

Private Sub Workbook_Open()
    Dim CellControl As CommandBarControl
    ' Assign shortcut to display calendar on SHIFT+CTRL+C
    Application.OnKey "+^{C}", "Module1.SpustitKalendar"
    Set CellControl = Application.CommandBars("Cell").Controls.Add(msoControlButton)
    With CellControl
        .Caption = "Vložit datum"
        .Style = msoButtonIconAndCaption
        .FaceId = 125
        .OnAction = "SpustitKalendar"
    End With
End Sub

FormControlClass:

Public WithEvents lblControl As MSForms.Label

Private Sub lblControl_Click()
    If Len(lblControl.Caption) = 0 Then Exit Sub
    Mesic = frmCalendar.lblMonth.Caption
    For i = 1 To 12
        If Format(DateSerial(2005, i, 1), "mmmm") = Mesic Then
            j = i
            Exit For
        End If
    Next i
    Rok = frmCalendar.lblYear.Caption
    ActiveCell = DateSerial(Rok, j, CInt(lblControl.Caption))
    frmCalendar.ZmenaKalendar
    Unload frmCalendar
    'ActiveCell.Select
End Sub

Private Sub lblControl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim iPocetDnu As Integer
   If Len(lblControl.Caption) = 0 Then
      frmCalendar.lblNameDay = ""
      frmCalendar.lblMath = ""
      Exit Sub
   End If
   Mesic = frmCalendar.lblMonth.Caption
   For i = 1 To 12
      If Format(DateSerial(2005, i, 1), "mmmm") = Mesic Then
         j = i
         Exit For
      End If
   Next i
   Rok = frmCalendar.lblYear.Caption
   iPocetDnu = DateSerial(Rok, j, CInt(lblControl.Caption)) - Date
   strSign = ""
   frmCalendar.lblNameDay = OFFSVATEK(lblControl.Caption & "." & j & ".")
   Select Case iPocetDnu
      Case Is < -4
         strMath = " dní"
      Case -4, -3, -2
         strMath = " dny"
      Case -1
         strMath = " den"
      Case 0
         frmCalendar.lblMath = ""
         Exit Sub
      Case 1
         strMath = " den"
         strSign = "+"
      Case 2, 3, 4
         strMath = " dny"
         strSign = "+"
      Case Is > 4
         strMath = " dní"
         strSign = "+"
   End Select
   frmCalendar.lblMath = strSign & iPocetDnu & strMath
End Sub

Vytvoř novou třídu, přejmenuj, vlož kód.

Jelikož události Open a BeforeClose máš,

tak si přidej do každé jeden řádek navíc

a úplně nahoru deklaraci do ThisWorkbook.

Tak jsem se k tomu po delší době dostal...

1. vytvořil jsem v xla novou třídu, přejmenoval na "EventsOfApplication" a vložil kód:

Option Explicit

Private WithEvents xlApp As Excel.Application

Private Sub Class_Initialize()
    Set xlApp = Application
End Sub

Private Sub Class_Terminate()
    Set xlApp = Nothing
End Sub

Private Sub XlApp_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If IsDate(ActiveCell.Value) Then
        Module1.SpustitKalendar
        Cancel = True
    End If
End Sub

2. Do ThisWorkBooku xla souboru jsem do události "Workbook_BeforeClose" přidal:

Set xlAppEvents = Nothing

3. Do ThisWorkBooku xla souboru jsem do události "Workbook_Open" přidal:

Set xlAppEvents = New EventsOfApplication

.... excel funguje bez chyb, ale stále spustit kalendář poklepem na buňku typu DATUM....

Poradí ještě někdo?

.. pro případ, kdy je v buňce datum

nebo pro prázdnou buňku s formátem

datumu (pro varianty dm + my + dmy)

If IsDate(ActiveCell) Or DateFormatedCell Then
   Module1.SpustiKalendar
EndIf

Pokus zjištění formátu prázdné buňky:

Function DateFormatedCell() As Boolean
    Dim bdf As Boolean, sdf As String
    On Error GoTo Function_Exit
    bdf = (CBool(InStr(ActiveCell.NumberFormat, "d")) _
        And CBool(InStr(ActiveCell.NumberFormat, "m"))) Or _
        (CBool(InStr(ActiveCell.NumberFormat, "m")) _
        And CBool(InStr(ActiveCell.NumberFormat, "y"))) Or _
        ((CBool(InStr(ActiveCell.NumberFormat, "d")) _
        And CBool(InStr(ActiveCell.NumberFormat, "m")) _
        And CBool(InStr(ActiveCell.NumberFormat, "y"))))
    
    If Not bdf Then Exit Function
    sdf = Format(Date, ActiveCell.NumberFormat)
    DateFormatedCell = IsDate(sdf)
    Exit Function
Function_Exit:
    On Error GoTo 0
End Function