Sunday, July 22, 2018

Excel workbooks Open password Cracker Code


Sub PasswordBreaker()
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
Filename = Application.GetOpenFilename(filefilter:="workbooks *.xls,*.xls")
For i = 1 To Len(Filename)
If Mid(Filename, i, 1) = "\" Then
mylen = i
End If
Next
wbkname = Right(Filename, Len(Filename) - mylen)
For i = 32 To 126: For j = 32 To 126: For k = 32 To 126
For l = 32 To 126: For m = 32 To 126: For i1 = 32 To 126
For i2 = 32 To 126: For i3 = 32 To 126: For i4 = 32 To 126
For i5 = 32 To 126: For i6 = 32 To 126: For n = 32 To 126


pswd = Trim(Chr(n) & Chr(i6) & Chr(i5) & _
Chr(i4) & Chr(i3) & Chr(i2) & Chr(i1) & Chr(m) & _
Chr(l) & Chr(k) & Chr(j) & Chr(i))
Workbooks.Open Filename
Application.StatusBar = pswd
DoEvents
If ActiveWorkbook.Name = wbkname Then
MsgBox "One usable password is " & Trim(Chr(n) & Chr(i6) & Chr(i5) & _
Chr(i4) & Chr(i3) & Chr(i2) & Chr(i1) & Chr(m) & _
Chr(l) & Chr(k) & Chr(j) & Chr(i))
Application.StatusBar = False
Exit Sub
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next

End Sub



Looking for local information? Find it on Yahoo! Local

Reading outlook emails from Shared Mailbox

Add reference Microsoft Outlook XX.X object Library

Sub OutlookTesting()

Dim folders As Outlook.folders
Dim folder As Outlook.MAPIFolder
Dim iRow As Integer
Dim Pst_Folder_Name
Dim MailboxName
Dim UnRow As Integer
Dim RESS As Outlook.Recipient
Dim Flag As Integer
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olfldr As Outlook.MAPIFolder
Dim foldername As Outlook.MAPIFolder
Dim sharedemail As Outlook.Recipient
Const SharedMailboxName As String = "abc@xyz.com" '  <-- font="" mailbox="" name="" shared="" your="">
<-- mailbox="" name="" p="" shared="" your="">
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set sharedemail = olNS.CreateRecipient(SharedMailboxName)

For x = 1 To olNS.Stores.Count  ' <-- all="" and="" configured="" i="" iterate="" mailbox="" mailboxes="" on="" outlook="" select="" target="" thorough=""><-- all="" and="" configured="" iterate="" mailbox="" mailboxes="" on="" outlook="" p="" select="" target="" thorough="">
    If olNS.Stores.Item(x).DisplayName = SharedMailboxName Then
        Set olfldr = olNS.Stores.Item(x).GetDefaultFolder(olFolderInbox)
    End If

Next

Set folder = olfldr

If folder = "" Then
   MsgBox "Invalid Data in Input"
   GoTo end_lbl1:
End If

'Read Through each Mail and export the details to Excel for Email Archival
Count = 1

For iRow = folder.Items.Count To 1 Step -1

    If (folder.Items(iRow).UnRead) Then
     
        ActiveSheet.Cells(Count + 1, 1).Value = folder.Items(iRow).SenderEmailAddress
        ActiveSheet.Cells(Count + 1, 2).Value = folder.Items(iRow).Subject
        ActiveSheet.Cells(Count + 1, 3).Value = folder.Items(iRow).To
        ActiveSheet.Cells(Count + 1, 4).Value = folder.Items(iRow).Body
        ActiveSheet.Cells(Count + 1, 5).Value = folder.Items(iRow).ReceivedTime
        ActiveSheet.Cells(Count + 1, 6).Value = folder.Items(iRow).SentOn
        ActiveSheet.Cells(Count + 1, 7).Value = folder.Items(iRow).Sensitivity
     
        Count = Count + 1

    End If
 
 
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
end_lbl1:
End Sub


Monday, August 1, 2011

GetUserID fro Environment

---- Paste this in General section -----------
 
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
 
 
--- Copy this function and use it in your program ----------
 
Function getUserID() As String
Dim lngLen As Long, lngX As Long
Dim strUserName As String
    strUserName = String$(254, 0)
    lngLen = 255
    lngX = apiGetUserName(strUserName, lngLen)
    If (lngX > 0) Then
        getUserID = Left$(strUserName, lngLen - 1)
    Else
        getUserID = vbNullString
    End If
End Function

Friday, April 8, 2011

Send email from SQL Server using stored procedure


CREATE Procedure dbo.sp_SQLSMTPMail
       @vcTo           varchar(2048) = null,
       @vcBody         varchar(8000) = '',
       @vcSubject      varchar(255)  = null,
       @vcAttachments  varchar(1024) = null,
       @vcQuery        varchar(8000) = null,
       @vcFrom         varchar(128)  = null,
       @vcCC           varchar(2048) = '',
      @vcSenderName   varchar(128)  = null, 
       @vcBCC          varchar(2048) = '',
      @vcSMTPServer   varchar(255)  = 'smtprelay.abc.com',    -- put local network smtp server name here
       @cSendUsing     char(1)       = '2',
       @vcPort         varchar(3)    = '25',
       @cAuthenticate  char(1)       = '0',
       @vcDSNOptions   varchar(2)    = '0',
       @vcTimeout      varchar(2)    = '30',
       @vcServerName   sysname       = null
As
/*******************************************************************/
--Name        : sp_SQLSMTPMail
--Server      : Generic
--Description : SQL smtp e-mail using CDOSYS, OLE Automation and a
--              network smtp server; For SQL Servers running on
--              windows 2000.
--
--Note        : Be sure to set the default for @vcSMTPServer above to 
--              the company network smtp server or you will have to 
--              pass it in each time.
--
--Comments    : Getting the network SMTP configured to work properly
--              may require engaging your company network or
--              server people who deal with the netowrk SMTP server.
--              Some errors that the stored proc returns relate to
--              incorrect permissions for the various SQL Servers to
--              use the SMTP relay server to bouce out going mail.
--              Without proper permissions the SQL server appears as
--              a spammer to the local SMTP network server.
--
--Parameters  : See the 'Syntax' Print statements below or call the
--              sp with '?' as the first input.
--History     :
/*******************************************************************/
Set nocount on
-- Determine if the user requested syntax.
If @vcTo = '?'
   Begin
      Print 'Syntax for sp_SQLSMTPMail (based on CDOSYS):'
      Print 'Exec master.dbo.sp_SQLSMTPMail'
      Print '     @vcTo          (varchar(2048)) - Recipient e-mail address list separating each with a '';'' '
      Print '                                       or a '',''. Use a ''?'' to return the syntax.'
      Print '     @vcBody        (varchar(8000)) - Text body; use embedded char(13) + char(10)'
      Print '                                       for carriage returns. The default is nothing'
      Print '     @vcSubject     (varchar(255))) - E-mail subject. The default is a message from'
      Print '                                       @@servername.'
      Print '     @vcAttachments (varchar(1024)) - Attachment list separating each with a '';''.'
      Print '                                       The default is no attachments.'
      Print '     @vcQuery       (varchar(8000)) - In-line query or a query file path; do not '
      Print '                                       use double quotes within the query.'
      Print '     @vcFrom        (varchar(128))  - Sender list defaulted to @@ServerName.'
      Print '     @vcCC          (varchar(2048)) - CC list separating each with a '';'' or a '','''
      Print '                                       The default is no CC addresses.'
      Print '     @vcBCC         (varchar(2048)) - Blind CC list separating each with a '';'' or a '','''
      Print '                                       The default is no BCC addresses.'
      Print '     @vcSMTPServer  (varchar(255))  - Network smtp server defaulted to your companies network'
      Print '                                       smtp server. Set this in the stored proc code.'
      Print '     @cSendUsing    (char(1))       - Specifies the smpt server method, local or network. The'
      Print '                                       default is network, a value of ''2''.'
      Print '     @vcPort        (varchar(3))    - The smtp server communication port defaulted to ''25''.'
      Print '     @cAuthenticate (char(1))       - The smtp server authentication method defaulted to '
      Print '                                       anonymous, a value of ''0''.'
      Print '     @vcDSNOptions  (varchar(2))    - The smtp server delivery status defaulted to none,'
      Print '                                       a value of ''0''.'
      Print '     @vcTimeout     (varchar(2))    - The smtp server connection timeout defaulted to 30 seconds.'
      Print '     @vcSenderName  (varchar(128))  - Primary sender name defaulted to @@ServerName.'
      Print '     @vcServerName  (sysname)       - SQL Server to which the query is directed defaulted'
      Print '                                       to @@ServerName.'
      Print ''
      Print ''
      Print 'Example:'
      Print 'sp_SQLSMTPMail ''<user@mycompany.com>'', ''This is a test'', @vcSMTPServer = <network smtp relay server>'
      Print ''
      Print 'The above example will send an smpt e-mail to <user@mycompany.com> from @@ServerName'
      Print 'with a subject of ''Message from SQL Server <@@ServerName>'' and a'
      Print 'text body of ''This is a test'' using the network smtp server specified.'
      Print 'See the MSDN online library, Messaging and Collaboration, at '
      Print 'http://www.msdn.microsoft.com/library/ for details about CDOSYS.'
      Print 'subheadings: Messaging and Collaboration>Collaboration Data Objects>CDO for Windows 2000>'
      Print 'Reference>Fields>http://schemas.microsoft.com/cdo/configuration/>smtpserver field'
      Print ''
      Print 'Be sure to set the default for @vcSMTPServer before compiling this stored procedure.'
      Print ''
      Return
   End

-- Declare variables
Declare @iMessageObjId    int
Declare @iHr              int
Declare @iRtn             int
Declare @iFileExists      tinyint
Declare @vcCmd            varchar(255)
Declare @vcQueryOutPath   varchar(50)
Declare @dtDatetime       datetime
Declare @vcErrMssg        varchar(255)
Declare @vcAttachment     varchar(1024)
Declare @iPos             int
Declare @vcErrSource      varchar(255)
Declare @vcErrDescription varchar(255)
-- Set local variables.
Set @dtDatetime = getdate()
Set @iHr = 0
-- Check for minimum parameters.
If @vcTo is null
   Begin
      Set @vcErrMssg = 'You must supply at least 1 recipient.'
      Goto ErrMssg
   End
-- CDOSYS uses commas to separate recipients. Allow users to use 
-- either a comma or a semi-colon by replacing semi-colons in the
-- To, CCs and BCCs.
Select @vcTo = Replace(@vcTo, ';', ',')
Select @vcCC = Replace(@vcCC, ';', ',')
Select @vcBCC = Replace(@vcBCC, ';', ',')
-- Set the default SQL Server to the local SQL Server if one 
-- is not provided to accommodate instances in SQL 2000.
If @vcServerName is null
   Set @vcServerName = @@servername
-- Set a default "subject" if one is not provided.
If @vcSubject is null
   Set @vcSubject = 'Message from SQL Server ' + @vcServerName
-- Set a default "from" if one is not provided.
If @vcFrom is null
   Set @vcFrom = 'SQL-' + Replace(@vcServerName,'\','_')
-- Set a default "sender name" if one is not provided.
If @vcSenderName is null
   Set @vcSenderName = 'SQL-' + Replace(@vcServerName,'\','_')
-- Create the SMTP message object.
EXEC @iHr = sp_OACreate 'CDO.Message', @iMessageObjId OUT
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error creating object CDO.Message.'
      Goto ErrMssg
   End
-- Set SMTP message object parameters.
-- To
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'To', @vcTo
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "To".'
      Goto ErrMssg
   End
-- Subject
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'Subject', @vcSubject
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "Subject".'
      Goto ErrMssg
   End
-- From
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'From', @vcFrom
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "From".'
      Goto ErrMssg
   End
-- CC
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'CC', @vcCC
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "CC".'
      Goto ErrMssg
   End
-- BCC
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'BCC', @vcBCC
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "BCC".'
      Goto ErrMssg
   End
-- DSNOptions
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'DSNOptions', @vcDSNOptions
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "DSNOptions".'
      Goto ErrMssg
   End
-- Sender
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'Sender', @vcSenderName
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "Sender".'
      Goto ErrMssg
   End
-- Is there a query to run?
If @vcQuery is not null and @vcQuery <> ''
   Begin
      -- We have a query result to include; temporarily send the output to the
      -- drive with the most free space. Use xp_fixeddrives to determine this.
      -- If a temp table exists with the following name drop it.
      If (Select object_id('tempdb.dbo.#fixeddrives')) > 0
         Exec ('Drop table #fixeddrives')
     
      -- Create a temp table to work with xp_fixeddrives.
      Create table #fixeddrives(
             Drive char(1) null,
             FreeSpace  varchar(15) null)
      -- Get the fixeddrive info.
      Insert into #fixeddrives Exec master.dbo.xp_fixeddrives
      -- Get the drive letter of the drive with the most free space
      -- Note: The OSQL output file name must be unique for each call within the same session.
      --       Apparently OSQL does not release its lock on the first file created until the session ends.
      --       Hence this alleviates a problem with queries from multiple calls in a cursor or other loop.
      Select @vcQueryOutPath = Drive + ':\TempQueryOut' +
                               ltrim(str(datepart(hh,getdate()))) +
                               ltrim(str(datepart(mi,getdate()))) +
                               ltrim(str(datepart(ss,getdate()))) +
                               ltrim(str(datepart(ms,getdate()))) + '.txt'
        from #fixeddrives
       where FreeSpace = (select max(FreeSpace) from #fixeddrives )
     
      -- Check for a pattern of '\\*\' or '?:\'.
      -- If found assume the query is a file path.
      If Left(@vcQuery, 35) like '\\%\%' or Left(@vcQuery, 5) like '_:\%'
         Begin
            Select @vcCmd = 'osql /S' + @vcServerName + ' /E /i' +
                            convert(varchar(1024),@vcQuery) +
                            ' /o' + @vcQueryOutPath + ' -n -w5000 '
         End
      Else
         Begin
            Select @vcCmd = 'osql /S' + @vcServerName + ' /E /Q"' + @vcQuery +
                            '" /o' + @vcQueryOutPath + ' -n -w5000 '
         End
      -- Execute the query
      Exec master.dbo.xp_cmdshell @vcCmd, no_output
      -- Add the query results as an attachment if the file was successfully created.
      -- Check to see if the file exists. Use xp_fileexist to determine this.
      -- If a temp table exists with the following name drop it.
      If (Select object_id('tempdb.dbo.#fileexists')) > 0
         Exec ('Drop table #fileexists')
     
      -- Create a temp table to work with xp_fileexist.
      Create table #fileexists(
             FileExists tinyint null,
             FileIsDirectory  tinyint null,
             ParentDirectoryExists  tinyint null)
      -- Execute xp_fileexist
      Insert into #fileexists exec master.dbo.xp_fileexist @vcQueryOutPath
      -- Now see if we need to add the file as an attachment
      If (select FileExists from #fileexists) = 1
         Begin
            -- Set a variable for later use to delete the file.
            Select @iFileExists = 1
            -- Add the file path to the attachment variable.
            If @vcAttachments is null
               Select @vcAttachments = @vcQueryOutPath
            Else
               Select @vcAttachments = @vcAttachments + '; ' + @vcQueryOutPath
         End
   End
-- Check for multiple attachments separated by a semi-colon ';'.
If @vcAttachments is not null
   Begin
      If right(@vcAttachments,1) <> ';'
         Select @vcAttachments = @vcAttachments + '; '
      Select @iPos = CharIndex(';', @vcAttachments, 1)
      While @iPos > 0
         Begin
            Select @vcAttachment = ltrim(rtrim(substring(@vcAttachments, 1, @iPos -1)))
            Select @vcAttachments = substring(@vcAttachments, @iPos + 1, Len(@vcAttachments)-@iPos)
            EXEC @iHr = sp_OAMethod @iMessageObjId, 'AddAttachment', @iRtn Out, @vcAttachment
            IF @iHr <> 0
               Begin
                  EXEC sp_OAGetErrorInfo @iMessageObjId, @vcErrSource Out, @vcErrDescription Out
                  Select @vcBody = @vcBody + char(13) + char(10) + char(13) + char(10) +
                                   char(13) + char(10) + 'Error adding attachment: ' +
                                   char(13) + char(10) + @vcErrSource + char(13) + char(10) +
                                   @vcAttachment
               End
            Select @iPos = CharIndex(';', @vcAttachments, 1)
         End
   End
-- TextBody
EXEC @iHr = sp_OASetProperty @iMessageObjId, 'TextBody', @vcBody
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message parameter "TextBody".'
      Goto ErrMssg
   End
-- Other Message parameters for reference
--EXEC @iHr = sp_OASetProperty @iMessageObjId, 'MimeFormatted', False
--EXEC @iHr = sp_OASetProperty @iMessageObjId, 'AutoGenerateTextBody', False
--EXEC @iHr = sp_OASetProperty @iMessageObjId, 'MDNRequested', True
-- Set SMTP Message configuration property values.
-- Network SMTP Server location
EXEC @iHr = sp_OASetProperty @iMessageObjId,
'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver").Value',
@vcSMTPServer
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message configuraton field "smtpserver".'
      Goto ErrMssg
   End
-- Sendusing
EXEC @iHr = sp_OASetProperty @iMessageObjId,
'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing").Value',
@cSendUsing
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message configuraton field "sendusing".'
      Goto ErrMssg
   End
-- SMTPConnectionTimeout
EXEC @iHr = sp_OASetProperty @iMessageObjId,
'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SMTPConnectionTimeout").Value',
@vcTimeout
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message configuraton field "SMTPConnectionTimeout".'
      Goto ErrMssg
   End
-- SMTPServerPort
EXEC @iHr = sp_OASetProperty @iMessageObjId,
'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SMTPServerPort").Value',
@vcPort
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message configuraton field "SMTPServerPort".'
      Goto ErrMssg
   End
-- SMTPAuthenticate
EXEC @iHr = sp_OASetProperty @iMessageObjId,
'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SMTPAuthenticate").Value',
@cAuthenticate
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error setting Message configuraton field "SMTPAuthenticate".'
      Goto ErrMssg
   End
-- Other Message Configuration fields for reference
--EXEC @iHr = sp_OASetProperty @iMessageObjId,
--'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SMTPUseSSL").Value',True
--EXEC @iHr = sp_OASetProperty @iMessageObjId,
--'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/LanguageCode").Value','en'
--EXEC @iHr = sp_OASetProperty @iMessageObjId,
--'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SendEmailAddress").Value', 'Test User'
--EXEC @iHr = sp_OASetProperty @iMessageObjId,
--'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SendUserName").Value',null
--EXEC @iHr = sp_OASetProperty @iMessageObjId,
--'Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/SendPassword").Value',null
-- Update the Message object fields and configuration fields.
EXEC @iHr = sp_OAMethod @iMessageObjId, 'Configuration.Fields.Update'
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error updating Message configuration fields.'
      Goto ErrMssg
   End
EXEC @iHr = sp_OAMethod @iMessageObjId, 'Fields.Update'
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error updating Message parameters.'
      Goto ErrMssg
   End
-- Send the message.
EXEC @iHr = sp_OAMethod @iMessageObjId, 'Send'
IF @iHr <> 0
   Begin
      Set @vcErrMssg = 'Error Sending e-mail.'
      Goto ErrMssg
   End
Else
   Print 'Mail sent.'
Cleanup:
   -- Destroy the object and return.
   EXEC @iHr = sp_OADestroy @iMessageObjId
   --EXEC @iHr = sp_OAStop
   -- Delete the query output file if one exists.
   If @iFileExists = 1
      Begin
         Select @vcCmd = 'del ' + @vcQueryOutPath
         Exec master.dbo.xp_cmdshell @vcCmd, no_output
      End
   Return
ErrMssg:
   Begin
      Print @vcErrMssg
      If @iHr <> 0
         Begin
            EXEC sp_OAGetErrorInfo @iMessageObjId, @vcErrSource Out, @vcErrDescription Out
            Print @vcErrSource
            Print @vcErrDescription
         End
      -- Determine whether to exist or go to Cleanup.
      If @vcErrMssg = 'Error creating object CDO.Message.'
         Return
      Else
         Goto Cleanup
   End
GO

Thursday, May 27, 2010

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

First add the "Microsoft windows common control 6.0"

Name the sheet as "Menus"
ABCDEFG
1LevelCaptionPosition/MacroDividerFaceIDControl TypeCheckbox
21My Menu1000
32&DayTRUE00
43&SundayModule3.cmd145300
53&MondayModule3.cmd219500
63&TuesdayModule3.cmd3212810
72&MonthTRUE00
83&JanModule3.cmd4320300
92&CarTRUE00
103&BMWModule3.cmd501

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

Thursday, March 18, 2010

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.

Monday, February 8, 2010

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

Friday, January 15, 2010

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

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

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

Tuesday, December 22, 2009

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

Monday, November 16, 2009

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