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

Like Operator (Usage in VB and VBA)

 Dim testCheck As Boolean


' The following statement returns True (does "F" satisfy "F"?)

testCheck = "F" Like "F"

' The following statement returns False for Option Compare Binary

' and True for Option Compare Text (does "F" satisfy "f"?)

testCheck = "F" Like "f"

' The following statement returns False (does "F" satisfy "FFF"?)

testCheck = "F" Like "FFF"

' The following statement returns True (does "aBBBa" have an "a" at the

' beginning, an "a" at the end, and any number of characters in

' between?)

testCheck = "aBBBa" Like "a*a"

' The following statement returns True (does "F" occur in the set of

' characters from "A" through "Z"?)

testCheck = "F" Like "[A-Z]"

' The following statement returns False (does "F" NOT occur in the

' set of characters from "A" through "Z"?)

testCheck = "F" Like "[!A-Z]"

' The following statement returns True (does "a2a" begin and end with

' an "a" and have any single-digit number in between?)

testCheck = "a2a" Like "a#a"

' The following statement returns True (does "aM5b" begin with an "a",

' followed by any character from the set "L" through "P", followed

' by any single-digit number, and end with any character NOT in

' the character set "c" through "e"?)

testCheck = "aM5b" Like "a[L-P]#[!c-e]"

' The following statement returns True (does "BAT123khg" begin with a

' "B", followed by any single character, followed by a "T", and end

' with zero or more characters of any type?)

testCheck = "BAT123khg" Like "B?T*"

' The following statement returns False (does "CAT123khg"?) begin with

' a "B", followed by any single character, followed by a "T", and

' end with zero or more characters of any type?)

testCheck = "CAT123khg" Like "B?T*"



For complete article follow the below link:

http://msdn.microsoft.com/en-us/library/swf8kaxw(VS.80).aspx

Open website with login and paswd using VBA

The program requires references to the following:

1 Microsoft Internet Controls
2. Microsoft HTML Object Library

The Internet control is used to browse the webpage and the HTML Objects are used to identify the username and password textboxes and submit the text using the control button.

Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Sub Login_2_Website()

Dim oHTML_Element As IHTMLElement
Dim sURL As String

On Error GoTo Err_Clear
sURL = "https://www.google.com/accounts/Login"
Set oBrowser = New InternetExplorer
oBrowser.Silent = True
oBrowser.timeout = 60
oBrowser.navigate sURL
oBrowser.Visible = True

Do
' Wait till the Browser is loaded
Loop Until oBrowser.readyState = READYSTATE_COMPLETE

Set HTMLDoc = oBrowser.Document

HTMLDoc.all.Email.Value = "sample@vbadud.com"
HTMLDoc.all.passwd.Value = "*****"

For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next

' oBrowser.Refresh ' Refresh If Needed
Err_Clear:
If Err <> 0 Then
Debug.Assert Err = 0
Err.Clear
Resume Next
End If
End Sub

Create Barchart using "REPT" function.

Here is the example of REPT function. To create BarChart

 

Units	Days	Share	Function
100	Sunday	|||||  5%	=REPT("|",100*A2/$A$9) &"  "& TEXT(A2/$A$9,"0%")
150	Monday	|||||||  8%	=REPT("|",100*A3/$A$9) &"  "& TEXT(A3/$A$9,"0%")
450	Tuesday	||||||||||||||||||||||  23%	=REPT("|",100*A4/$A$9) &"  "& TEXT(A4/$A$9,"0%")
300	Wednesday	|||||||||||||||  15%	=REPT("|",100*A5/$A$9) &"  "& TEXT(A5/$A$9,"0%")
300	Thursday	|||||||||||||||  15%	=REPT("|",100*A6/$A$9) &"  "& TEXT(A6/$A$9,"0%")
400	Friday	||||||||||||||||||||  20%	=REPT("|",100*A7/$A$9) &"  "& TEXT(A7/$A$9,"0%")
300	Saturday	|||||||||||||||  15%	=REPT("|",100*A8/$A$9) &"  "& TEXT(A8/$A$9,"0%")
2000	Total

 

http://www.vbatalent.blogspot.com

---

Now, send attachments up to 25MB with Yahoo! India Mail. Learn how.

Remove workbook password.

'****************************************************************************
' Main procedure
' Open the workbook which you wants to remove password and run the procedure
'****************************************************************************
Sub PasswordBreaker1()

Dim wkb As Excel.Workbook
Set wkb = ActiveWorkbook

Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

ActiveWorkbook.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

Application.StatusBar = Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

If Not IsProtected(wkb) Then
MsgBox "One usable password is " & Chr(i) & Chr(j) & _
Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

Application.StatusBar = False

Exit Sub

End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next

End Sub

 

Function IsProtected(objXL As Object) As Boolean
Dim wksht As Excel.Worksheet
Dim cell As Excel.Range
Select Case TypeName(objXL)
 
  Case "Workbook"
    If objXL.ProtectStructure Then
      IsProtected = True
      Exit Function
    Else
        IsProtected = False
      Exit Function
    End If
End Select
End Function

---

Add whatever you love to the Yahoo! India homepage. Try now!

Append data from Multiple workbooks without opening the workbooks

Sub Main

Call AppendData

End Sub

 

 

Function GetFolder(ByVal DefaultPath As String)

On Error Resume Next

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
jmp1:

With fd
.InitialFileName = DefaultPath & "\"
.Show
End With

GetFolder = fd.SelectedItems(1)
If GetFolder = Empty Then GoTo errHandler
Exit Function
errHandler:
MsgBox "Please select a folder."
GoTo jmp1

End Function

 

 

Sub AppendData()

Dim folderpath As String
Dim cnt As DAO.Database
Dim rst As DAO.Recordset

Sheets(1).Select
Range("A2").Select

folderpath = GetFolder("C:")

With Application.FileSearch
.NewSearch
.LookIn = folderpath
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
   
    For i = 1 To .FoundFiles.Count
   
        Set cnt = DBEngine.OpenDatabase(.FoundFiles(i), False, False, "Excel 8.0")
        Set rst = cnt.OpenRecordset("Sheet1$")

        ActiveCell.CopyFromRecordset rst
        Cells(Range("E1").End(xlDown).Row + 1, 1).Select

        rst.Close
        cnt.Close
       
    Next
   
   
End With

End Sub

 

For worksheet example check this url http://groups.google.co.in/group/myvbagroup?hl=en

 

---

See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

Conditional Ranking in Excel

Here is the example of Conditional Ranking

 

	A	B	C	D	E
1	Date	Time	IN /Out	Ranking as per Dates	Done
2	2/1/2009	8:50	IN	1	=SUMPRODUCT(($A$2:$A$13=A2)*(B2>$B$2:$B$13))+1
3	2/1/2009	13:10	OUT	2	=SUMPRODUCT(($A$2:$A$13=A3)*(B3>$B$2:$B$13))+1
4	2/1/2009	14:00	IN	3	=SUMPRODUCT(($A$2:$A$13=A4)*(B4>$B$2:$B$13))+1
5	2/2/2009	8:50	IN	1	=SUMPRODUCT(($A$2:$A$13=A5)*(B5>$B$2:$B$13))+1
6	2/2/2009	13:10	OUT	2	=SUMPRODUCT(($A$2:$A$13=A6)*(B6>$B$2:$B$13))+1
7	2/1/2009	23:00	OUT	4	=SUMPRODUCT(($A$2:$A$13=A7)*(B7>$B$2:$B$13))+1
8	2/2/2009	23:00	OUT	4	=SUMPRODUCT(($A$2:$A$13=A8)*(B8>$B$2:$B$13))+1
9	2/3/2009	8:50	IN	1	=SUMPRODUCT(($A$2:$A$13=A9)*(B9>$B$2:$B$13))+1
10	2/3/2009	13:10	OUT	2	=SUMPRODUCT(($A$2:$A$13=A10)*(B10>$B$2:$B$13))+1
11	2/2/2009	14:00	IN	3	=SUMPRODUCT(($A$2:$A$13=A11)*(B11>$B$2:$B$13))+1
12	2/3/2009	23:00	OUT	3	=SUMPRODUCT(($A$2:$A$13=A12)*(B12>$B$2:$B$13))+1
13	2/1/2009	23:50	IN	5	=SUMPRODUCT(($A$2:$A$13=A13)*(B13>$B$2:$B$13))+1

---

See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

How to create Dynamic validation list in excel

Example:

 

Let say I have two sheets in a workbook

 

1) Lists

2) Answer

 

Sheet Lists :  has two list as follows

 

 

Sheet "Answer" is as follows

 

 

1) Create Names as follows ( Insert > Names > Define)

 

Name	Sheet Name	Formula
Type	List	=OFFSET(List!$A$2,0,0,COUNTA(List!$A:$A)-1,1)
List1	List	=List!$B:$B
List2		=OFFSET(List!$C$1,MATCH(Answer!$A33,List1,0)-1,0,COUNTIF(List1,Answer!$A33),1)

 

 

2) Go to Sheet "Answer" select column A and select Data>Validation from Menu.

3) Select List from Allow drop down.

4) and write  =type in Source textbox press OK.

5) Select the column B and Select Data>Validation from Menu.

6) Select List from Allow drop down.

7) and write  =List2 in Source textbox press OK

 

 

Send mail without using mail clients (Outlook) through VBA

Sub Sendmail()

Set imsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
 
 
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
    .Item("http://schemas.Microsoft.Com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Range("B4").Value
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailid
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = pswd
    .Update
End With
 
strBody = " Attached you will  find your MMO notifications from <our company name here> on ship date: " & Format(Date, "mm/dd/yyyy")
 
With imsg
    Set .Configuration = iConf
    .To = mailid
    .CC = ""
    .BCC = ""
    .From = mailid
    .Subject = "Manual Markout Notification - " & Format(Date, "mm/dd/yyyy")
    .TextBody = strBody
    .AddAttachment (ThisWorkbook.Path & "/" & Replace(Replace(shtData.Range("AC2").Value, ".", ""), "/", "") & " " & Format(Date, "mm-dd-yyyy") & ".mhtml")
    .Send
End With
Set Flds = Nothing
Set imsg = Nothing

Exit Sub

Set Flds = Nothing
Set imsg = Nothing

End Sub

---

Looking for local information? Find it on Yahoo! Local

Conditional MIN() & MAX()

We can get the conditional Minimum and Maximum values using as array function.

function used as follows

Press CTRL+Shift+Enter ..... to get result or convert the formula as array function.

Check the Autofilter whether it is on or Off

Sub CheckAutofilter()

Dim wks As Worksheet

 

For Each wks In ActiveWorkbook.Worksheets

Range("A2").Select
If Not ActiveSheet.AutoFilterMode = True Then
Selection.AutoFilter
Else
Selection.AutoFilter
End If

Next

End Sub

---

See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

Import Excel file using VBA in Access.

'********** Component details ****************
' Add "Microsoft office 10.1 Object Library from Tools > Referance.
' Command2 as Browse Button
' Command3 as Import Button
' Text0 as Textbox
'*********************************************

Private Sub Command2_Click()
' For Get the traget file name along with path
On Error GoTo lb1
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Show
Text0.Value = fd.SelectedItems(1)
Exit Sub
lb1:
MsgBox "No File selected"
Text0.Value = Empty
End Sub


Private Sub Command3_Click()
' To import the targeted file for which path is stored in "Text0" Textbox
aa = InputBox("Please enter the 'Table Name'", "Table Name", "Tbl" & Format(Now, "hhmmss"))
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel, aa, Text0.Value, -1
End Sub