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

[ΤΖΙΜΗΣ]

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

[Tasos]

Καλημέρα σε όλους!
Τζίμη, στη λειτουργική μονάδα "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

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

Με εκτίμηση

Τάσος

[ΤΖΙΜΗΣ]

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

[ΤΖΙΜΗΣ]

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

[Tasos]

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

Δοκίμασε:

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..........

[Tasos]

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

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

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

Πως;

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

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

Φιλικά

Τάσος

[ΤΖΙΜΗΣ]

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