Create Dynamic commandbar (Menu Bar) in Excel :Easy to change

First add the "Microsoft windows common control 6.0"

Name the sheet as "Menus"

	A	B	C	D	E	F	G
1	Level	Caption	Position/Macro	Divider	FaceID	Control Type	Checkbox
2	1	My Menu	10			0	0
3	2	&Day		TRUE		0	0
4	3	&Sunday	Module3.cmd1		453	0	0
5	3	&Monday	Module3.cmd2		195	0	0
6	3	&Tuesday	Module3.cmd3		2128	1	0
7	2	&Month		TRUE		0	0
8	3	&Jan	Module3.cmd4		3203	0	0
9	2	&Car		TRUE		0	0
10	3	&BMW	Module3.cmd5			0	1

and call below module on workbook_open event 

Sub CreateMenu()
'   This sub should be executed when the workbook is opened.
'   NOTE: There is no error handling in this subroutine

    Dim MenuSheet As Worksheet
    Dim MenuObject As CommandBarPopup

    Dim MenuItem As Object
    Dim submenuitem As CommandBarButton
    'Dim submenuitem1 As CommandBarControl
    Dim Row As Integer
    Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId, cntType, Chkflg

''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Location for menu data
    Set MenuSheet = ThisWorkbook.Sheets("Menus")
''''''''''''''''''''''''''''''''''''''''''''''''''''

'   Make sure the menus aren't duplicated
    Call DeleteMenu
   
'   Initialize the row counter
    Row = 2

'   Add the menus, menu items and submenu items using
'   data stored on MenuSheet
   
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        With MenuSheet
            MenuLevel = .Cells(Row, 1)
            Caption = .Cells(Row, 2)
            PositionOrMacro = .Cells(Row, 3)
            Divider = .Cells(Row, 4)
            FaceId = .Cells(Row, 5)
            NextLevel = .Cells(Row + 1, 1)
            cntType = .Cells(Row, 6)
            Chkflg = .Cells(Row, 6)
        End With
       
        Select Case MenuLevel
            Case 1 ' A Menu
'              Add the top-level menu to the Worksheet CommandBar
                Set MenuObject = Application.CommandBars(1). _
                    Controls.Add(Type:=msoControlPopup, _
                    Before:=PositionOrMacro, _
                    Temporary:=True)
                MenuObject.Caption = Caption
           
            Case 2 ' A Menu Item
                If NextLevel = 3 Then
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
                Else
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
                    MenuItem.OnAction = PositionOrMacro
                End If
                MenuItem.Caption = Caption
                If FaceId <> "" Then MenuItem.FaceId = FaceId
                If Divider Then MenuItem.BeginGroup = True
           
            Case 3 ' A SubMenu Item
                   
                    Select Case cntType
                   
                    Case 0
                        With MenuItem.Controls.Add(Type:=msoControlButton)
                                .Caption = Caption
                                .OnAction = PositionOrMacro
                                If Chkflg = 1 Then .State = msoButtonUp
                                If FaceId <> "" Then .FaceId = FaceId
                                If Divider Then .BeginGroup = True
                               
                        End With
                    Case 1
                        With MenuItem.Controls.Add(Type:=msoControlEdit)
                                .Caption = Caption
                                .OnAction = PositionOrMacro
                               
                                'If FaceId <> "" Then .FaceId = FaceId
                                If Divider Then .BeginGroup = True
                               
                       
                       
                        End With
                    Case 2
                   
                    End Select
               

               
                       
        End Select
       
        Row = Row + 1
    Loop
End Sub

Sub DeleteMenu()
'   This sub should be executed when the workbook is closed
'   Deletes the Menus
    Dim MenuSheet As Worksheet
    Dim Row As Integer
    Dim Caption As String
   
    On Error Resume Next
    Set MenuSheet = ThisWorkbook.Sheets("Menus")
    Row = 2
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        If MenuSheet.Cells(Row, 1) = 1 Then
            Caption = MenuSheet.Cells(Row, 2)
            Application.CommandBars(1).Controls(Caption).Delete
        End If
        Row = Row + 1
    Loop
    On Error GoTo 0
End Sub

Work with Excel from Access ( Web Query)

Sub importDatafromWEB()

On Error GoTo lb1:

'********************************************
' Add Library "Microsoft excel 10.0 object library"
'
'********************************************

Dim exl As Object

Dim wbk As Object

Dim sht As Object

Set exl = CreateObject("Excel.application")

Set wbk = exl.Workbooks.Add

Kill "C:\myfile.xls"

exl.ActiveWorkbook.SaveAs "C:\myfile.xls"

'exl.Visible = True

exl.Windows("myfile.xls").Activate

    With exl.ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.x-rates.com/d/INR/table.html", Destination:=exl.Workbooks("myfile.xls").Sheets("Sheet1").Range("A1"))

        .Name = "table"

        .FieldNames = True

       .RowNumbers = False

        .FillAdjacentFormulas = False

        .PreserveFormatting = True

        .RefreshOnFileOpen = False

        .BackgroundQuery = True

        .RefreshStyle = xlOverwriteCells

        .SavePassword = False

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .WebSelectionType = xlSpecifiedTables

        .WebFormatting = xlWebFormattingNone

        .WebTables = "14"

        .WebPreFormattedTextToColumns = True

        .WebConsecutiveDelimitersAsOne = True

        .WebSingleBlockTextImport = False

        .WebDisableDateRecognition = False

        .WebDisableRedirections = False

        .Refresh BackgroundQuery:=False

    End With

exl.ActiveWorkbook.Save

exl.ActiveWorkbook.Close Savechanges:=False

exl.Quit

Exit Sub

lb1:

MsgBox Err.Number & vbNewLine & Err.Description

End Sub

---

The INTERNET now has a personality. YOURS! See your Yahoo! Homepage.

Working with word using VBA in Excel

Sub Createwordapp()

Dim wdapp As Object

Dim wddoc As Object

'**** Creating word application object ********

Set wdapp = CreateObject("Word.application")

'**** Adding new document to word document *******
wdapp.documents.Add

'**** Making word application visible ********

wdapp.Visible = True

'**** Adding Text to document ************

With wdapp.Selection
.typetext Text:="This is my document"
.typeparagraph
.typetext Text:="Thank You"
.typeparagraph
End With


' **** Prompting and saving word document *********

wdapp.activedocument.SaveAs Application.GetSaveAsFilename(InitialFileName:="Doc1", filefilter:="word document (*.doc),*.doc")

'**** Closing word document *******

wdapp.activedocument.Close

'**** closing word application *******

wdapp.Quit

End Sub

Convert Numbers into words

Function Inwords(ByVal Nvalue As Double)

On error goto lb1

Dim intDecimal As String
Dim intTens As String
Dim inthundred As String
Dim intthousand As String
Dim intLakh As String
Dim intcrore As String

Dim strValue As String

strValue = Format(Nvalue, "#0.00")
intDecimal = Right(strValue, 2)


'******* Converting Crore place into words **************


If Nvalue >= 10000000 Then

If Len(strValue) >= 12 Then

intcrore = Left(Right(strValue, 12), 2)

ElseIf Len(strValue) >= 11 Then

intcrore = Left(Right(strValue, 11), 1)

End If

If CInt(intcrore) > 19 Then

intcrore = completetens(Left(intcrore, 1) * 10) & " " & Tens(Right(intcrore, 1)) & " Crore "

ElseIf CInt(intcrore) <> 0 Then

intcrore = Tens(intcrore) & " Crore "

Else

intcrore = ""

End If

End If



'******* Converting Lakh place into words **************


If Nvalue >= 100000 Then

If Len(strValue) >= 10 Then

intLakh = Left(Right(strValue, 10), 2)

ElseIf Len(strValue) >= 9 Then

intLakh = Left(Right(strValue, 9), 1)

End If

If CInt(intLakh) > 19 Then

intLakh = completetens(Left(intLakh, 1) * 10) & " " & Tens(Right(intLakh, 1)) & " Lac "

ElseIf CInt(intLakh) <> 0 Then

intLakh = Tens(intLakh) & " Lac "

Else

intLakh = ""

End If

End If


'******* Converting Thousand place into words **************

If Nvalue >= 1000 Then

If Len(strValue) >= 8 Then

intthousand = Left(Right(strValue, 8), 2)

ElseIf Len(strValue) >= 7 Then

intthousand = Left(Right(strValue, 7), 1)

End If

If CInt(intthousand) > 19 Then

intthousand = completetens(Left(intthousand, 1) * 10) & " " & Tens(Right(intthousand, 1)) & " Thousand "

ElseIf CInt(intthousand) <> 0 Then

intthousand = Tens(intthousand) & " Thousand "

Else

intthousand = ""

End If

End If


'******* Converting Hundred place into words **************

If Nvalue >= 100 Then

If CInt(Left(Right(strValue, 6), 1)) <> 0 Then inthundred = Tens(Left(Right(strValue, 6), 1)) & " Hundred "

Else
inthundred = ""

End If


'******* Converting Ones and Tens places into words **************

intTens = Left(Right(strValue, 5), 2)
If Nvalue >= 1 And CInt(intTens) <> 0 Then



If CInt(intTens) > 19 Then

intTens = completetens(Left(intTens, 1) * 10) & " " & Tens(Right(intTens, 1)) & " "
Else
intTens = Tens(intTens) & " "

End If

Else
intTens = ""

End If



'******* Converting Decimals places into words **************

If CInt(intDecimal) <> 0 Then

If CInt(intDecimal) > 19 Then

intDecimal = completetens(Left(intDecimal, 1) * 10) & " " & Tens(Right(intDecimal, 1)) & " Paise "
Else
intDecimal = Tens(intDecimal) & " Paise "

End If
Else
intDecimal = ""

End If



If intDecimal <> "" Then

mystring = intcrore & intLakh & intthousand & inthundred & intTens & "and " & intDecimal & "Only"
Else
mystring = intcrore & intLakh & intthousand & inthundred & intTens & "Only"
End If
inwords = Trim(mystring)

exit function
lb1:
inwords =""

End Function



Function Tens(IntValue)

Select Case IntValue

Case 1
Tens = "One"
Case 2
Tens = "Two"
Case 3
Tens = "Three"
Case 4
Tens = "Four"
Case 5
Tens = "Five"
Case 6
Tens = "Six"
Case 7
Tens = "Seven"
Case 8
Tens = "Eight"
Case 9
Tens = "Nine"
Case 10
Tens = "Ten"
Case 11
Tens = "Eleven"
Case 12
Tens = "Twelve"
Case 13
Tens = "Thirteen"
Case 14
Tens = "Fourteen"
Case 15
Tens = "Fifteen"
Case 16
Tens = "Sixteen"
Case 17
Tens = "Seventeen"
Case 18
Tens = "Eighteen"
Case 19
Tens = "Nineteen"
End Select

End Function

Function completetens(IntValue)

Select Case IntValue
Case 20
completetens = "Twenty"
Case 30
completetens = "Thirty"
Case 40
completetens = "Fourty"
Case 50
completetens = "Fifty"
Case 60
completetens = "Sixty"
Case 70
completetens = "Seventy"
Case 80
completetens = "Eighty"
Case 90
completetens = "Ninety"
End Select

End Function

Click here to download addin

Create custom command bar in access using VBA

Sub CreateCommandBar()
Dim myCB As CommandBar
Dim myCPup1 As CommandBarPopup
Dim myCP1Btn1 As CommandBarButton


' Delete the commandbar if it exists already
On Error Resume Next
Application.CommandBars("Training Manager").Delete

' Create a new Command Bar
Set myCB = CommandBars.Add(Name:="Training Manager", Position:=msoBarTop)

'************* Menu 1 Details *****************************

If encrpt(GetSetting(appname:="Profile", Section:="class", Key:="Utype", Default:=encrpt("Dummy"))) <> "ADMIN" Then GoTo lb2

' Add popup menu 1 to this bar
Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "T&rainings"

' Add button 1 to popup menu 1
Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Create Training"
.Style = msoButtonAutomatic
.FaceId = 137
.OnAction = "=showCreatTrainings()"

End With

' Add button 2 to popup menu 1
Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Edit Trainings"
.Style = msoButtonIconAndCaption
.FaceId = 162
.OnAction = "=showEditTrainings()"
End With

' Add button 2 to popup menu 1
Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "Add/Edit &Other Info"
.Style = msoButtonIconAndCaption
.FaceId = 162
.OnAction = "=showOtherinfo()"
End With

'************* Menu 2 Details *****************************

Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "A&ssociate(s)"

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&New Associate"
.Style = msoButtonAutomatic
.FaceId = 326
.OnAction = "=CreateAssociate()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Edit Associate(s) Info"
.Style = msoButtonAutomatic
.FaceId = 327
.OnAction = "=editAssociate()"

End With


Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Assign Trainings"
.Style = msoButtonAutomatic
.FaceId = 855
.OnAction = "=AssignAssociate()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Training Nomination"
.Style = msoButtonAutomatic
.FaceId = 29
.OnAction = "=SendNominations()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Generate Password"
.Style = msoButtonAutomatic
.FaceId = 29
.OnAction = "=RestPassword()"

End With


'************* Menu 3 Details *****************************

Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "Re&ports"

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Group Status"
.Style = msoButtonAutomatic
.FaceId = 435
.OnAction = "=GroupReport()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Nomination Report"
.Style = msoButtonAutomatic

.OnAction = "=NominationReport()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "Sche&duled Trainins"
.Style = msoButtonAutomatic

.OnAction = "=SchecduledTrainings()"

End With

lb2:

'************* Menu 4 Details *****************************

Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "&Events && others"

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Celebrations"
.Style = msoButtonAutomatic
.FaceId = 608
.OnAction = "=myevents()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "Change &Password"
.Style = msoButtonAutomatic
.FaceId = 505
.OnAction = "=ChangePassword()"

End With


myCB.Visible = True

End Sub

Function showCreatTrainings()
DoCmd.OpenTable TableName:="tbl_TrainingMaster", View:=acViewNormal, Datamode:=acAdd
End Function

Create 30 Days evaluation restriction for your tool. (Excel)

you can now secure/restrict the usage of your tool/macro by adding below code in excel.



Private Sub Workbook_Open()


Dim Sdate As Date

Dim edate As Date

Dim Rkey As String


Sdate = encrpt(GetSetting(appname:="App", Section:="class", key:="SD", Default:=encrpt("01/01/2000")))

edate = encrpt(GetSetting(appname:="App", Section:="class", key:="ED", Default:=encrpt("01/01/2000")))

Rkey = encrpt(GetSetting(appname:="App", Section:="Class", key:="Key", Default:="pxbac"))



If Sdate = "01/01/2000" And edate = "01/01/2000" And Rkey = "pxbac" Then



MsgBox "Its a Trial version"



SaveSetting appname:="App", Section:="class", key:="SD", Setting:=encrpt(Date)

SaveSetting appname:="App", Section:="class", key:="ED", Setting:=encrpt(Date + 30)

SaveSetting appname:="App", Section:="class", key:="Key", Setting:=encrpt("trial")





ElseIf Sdate <> "01/01/2000" And edate <> "01/01/2000" And Rkey = "trial" Then

MsgBox edate - Date & " Days Left."



ElseIf Sdate <> "01/01/2000" And edate <> "01/01/2000" And Rkey = "mingo" Then

MsgBox "Complete version"



End If



End Sub

-----------------------------------------------------------------------------------------------

Function encrpt(ecrptthis)


Dim stringchar, keychar, crptchar


For i = 1 To Len(ecrptthis)

stringchar = Asc(Mid(ecrptthis, i, 1))

keychar = Asc(Mid(keygen, i, 1))

crptchar = stringchar Xor keychar

strencrpt = strencrpt & Chr(crptchar)

Next

encrpt = strencrpt

End Function
 
-------------------------------------------------------------------------------------
 
Function keygen()


keygen = "adflsn4w#$^23%@^$FDSDTwqaer^ERQ#W#$^*%$%DE!3fqDTw6rt*^$#"

End Function