Forum - Γενικά Προσθήκη Εντολής στο Σύντομο Μενού

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Γενικά] Προσθήκη Εντολής στο Σύντομο Μενού (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/2459-prosthiki-entolis-sto-sintomo-menoi.html)

Προσθήκη Εντολής στο Σύντομο Μενού

Καλημέρα σε όλους τους καλούς φίλους.Θα ήθελα να ρωτήσω το εξής.
Πως μπορούμε να προσθέσουμε μία εντολή εκτέλεσης στο σύντομο μενού (δεξί κλικ).
Ας υποθέσουμε ότι στο κελί Α1 τοποθετούμε ένα ΑΦΜ και μετά την καταχώριση να έχουμε μία εντολή ελέγχου κάνοντας δεξί κλίκ, ώστε αν θέλουμε προαιρετικά να προβούμε σε έλεγχο ορθότητας του συγκεκριμένου ΑΦΜ.
Ευχαριστώ εκ των προτέρων
Τζίμης

Καλημέρα σε όλους!
Τζίμη, στη λειτουργική μονάδα "ThisWorkBook" Δοκίμασε τον παρακάτω κώδικα:

Κώδικας:

Option Explicit
 

Private Sub Workbook_Open()

' Mέθοδος με κουμπί στο μενού "Cell"(Χρειάζεται η αναφορά του Microsoft Office XX.0 Object Library)

    Dim ctl As Office.CommandBarControl

    Set ctl = Application.CommandBars("cell").Controls.Add(1, , , 1, True)

    With ctl

        .FaceId = 1559

        .Caption = "Έλεγχος Α.Φ.Μ."

        .OnAction = ThisWorkbook.CodeName & ".CheckAFM"

    End With

    Application.CommandBars("cell").Controls(2).BeginGroup = True

    

    ' Mέθοδος με συνδυασμό πλήκτρων CTRL + Q (δεν χρειάζεται η αναφορά του Microsoft Office XX.0 Object Library)

    

    ' Application.OnKey "^q", ThisWorkbook.CodeName & ".CheckAFM"

End Sub
 

Friend Sub CheckAFM()

    Dim a1 As String, c As Range

    Set c = Selection(1)

    a1 = c.Address(False, False)

    If Trim(c) = "" Then Exit Sub

    If Evaluate("=IF(LEN(" & _

            a1 & ")=9,IF(MOD(MOD(SUM(MID(" & _

            a1 & ",9-ROW($1:$8),1)*2^ROW($1:$8)),11),10)=RIGHT(" & _

            a1 & ",1)*1,1,0),0)") Then

        MsgBox "Σωστό Α.Φ.Μ. " & " ( " & a1 & " )", vbInformation

    Else

        MsgBox "Λάθος Α.Φ.Μ. " & " ( " & a1 & " )", vbExclamation

    End If

End Sub

Καλή συνέχεια!

Με εκτίμηση

Τάσος

Τάσο ακριβώς αυτό ήθελα.Υπέροχο.Θα μελετήσω τον κώδικα που έγραψες και αν έχω κάποια απορία θα επανέλθω.
Να είσαι πάντα καλά
Τζίμης

Τάσο θα ήθελα να σε ρωτήσω και κάτι ακόμη.
Μπορούμε να έχουμε και μια επιπλέον επιλογή στο δεξί κλίκ ώστε να με συνδέει με τη διεύθυνση:
Γενική Γραμματεία Πληροφοριακών Συστημάτων
Ευχαριστώ

Καλησπέρα Τζίμη!

Δοκίμασε:

Κώδικας:

Option Explicit
 

Private Sub Workbook_Open()
 ' Mέθοδος με κουμπί στο μενού "Cell"(Χρειάζεται η αναφορά του Microsoft Office XX.0 Object Library)
 
 ' Τα κοκκινισμένα ψηφία δηλώνουν τη θέση της εντολής στο μενού.
 

    Dim ctl As Office.CommandBarControl

    With Application.CommandBars("cell")

        Set ctl = .Controls.Add(1, , , 1, True)

        With ctl

            .FaceId = 1559

            .Caption = "Έλεγχος Α.Φ.Μ."

            .OnAction = ThisWorkbook.CodeName & ".CheckAFM"

            .Parent.Controls(2).BeginGroup = True

        End With
 

        Set ctl = .Controls.Add(1, , , 2, True)

        With ctl

            .FaceId = 610

            .Caption = "Γ.Γ.Π.Σ"

            .Tag = "http://www.gsis.gr/gsis_site/"

            .OnAction = ThisWorkbook.CodeName & ".GotoURL"

        End With
 

        Set ctl = .Controls.Add(1, , , 3, True)

        With ctl

            .FaceId = 263

            .Caption = "Excel - Ερωτήσεις / Απαντήσεις"

            .Tag = "http://www.ms-office.gr/forum/excel-erotiseis-apantiseis/"

            .OnAction = ThisWorkbook.CodeName & ".GotoURL"

            .Parent.Controls(2).BeginGroup = True

        End With

    End With

End Sub
 

Friend Sub CheckAFM()

    Dim a1 As String, c As Range

    Set c = Selection(1)

    a1 = c.Address(False, False)

    If Trim(c) = "" Then Exit Sub

    If Evaluate("=IF(LEN(" & _

            a1 & ")=9,IF(MOD(MOD(SUM(MID(" & _

            a1 & ",9-ROW($1:$8),1)*2^ROW($1:$8)),11),10)=RIGHT(" & _

            a1 & ",1)*1,1,0),0)") Then

        MsgBox "Σωστό Α.Φ.Μ. " & " ( " & a1 & " )", vbInformation

    Else

        MsgBox "Λάθος Α.Φ.Μ. " & " ( " & a1 & " )", vbExclamation

    End If

End Sub
 

Friend Sub GotoURL()
 'Αναφορά στη βιβλιοθήκη Microsoft "Shell Controls and Automation" (C:\Windows\System32\shell32.dll)

    Dim strUrl As String

    strUrl = Application.CommandBars.ActionControl.Tag

    Dim oShell As New Shell32.Shell

    oShell.ShellExecute strUrl, "", "", , 1

End Sub

Τάσο καταπληκτικό.Όμως μου χτυπάει ο κώδικας στην εντολή:
Dim oShell As New Shell32..........

Στον κώδικα μου υπάρχει σχόλιο σχετικά με την αναφορά "Shell Controls and Automation"

Η αναφορά αυτή χρειάζεται για να ανοίξει το συγκεκριμένο URL με τον προεπιλεγμένο περιηγητή Διαδικτύου του συστήματος (στον οποίο ίσως έχουν αποθηκευτεί δεδομένα πρόσβασης για την ιστοσελίδα).

Πρόσθεσε την αναφορά στη βιβλιοθήκη Microsoft "Shell Controls and Automation"

Πως;

Πάτησε Tools>References και στο παράθυρο που θα εμφανιστεί πάτησε "Browse..."

Επίλεξε τη βιβλιοθήκη shell32.dll στη διαδρομή C:\Windows\System32\ , κλείσε με ΟΚ και δοκίμασε ξανά.

Φιλικά

Τάσος

Τάσο ευχαριστώ πολύ.Δούλεψε υπέροχα.
Με εκτίμηση Τζίμης