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
Friday, January 15, 2010
Friday, January 8, 2010
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
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
Friday, January 1, 2010
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
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
Subscribe to:
Posts (Atom)