VBA for Excel & Access

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

/*******************************************************************/
--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"

	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

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

Sunday, November 15, 2009

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.

Pages