Procedures Using VBA Example..

Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset

Private Sub CommandButton1_Click()

Dim com As ADODB.Command

'without Parameter
'-----------------------------------------------------
con.ConnectionString = "Provider=MSDAORA;Data Source=orcl_man;User Id=manzoor;Password=ahamed;Persist Security Info = True;"
con.Open
Set com = New ADODB.Command
com.CommandText = "begin ins_emp; end;"
com.ActiveConnection = con
com.Execute
con.Close
'--------------------------------------
'--------------------------------------
'With Parameter
'---------------------------------------
Dim cmd As New ADODB.Command
Dim p1 As New ADODB.Parameter
Dim p2 As New ADODB.Parameter
Dim p3 As New ADODB.Parameter
Dim p4 As New ADODB.Parameter

con.ConnectionString = "Provider=MSDAORA;Data Source=orcl_man;User Id=manzoor;Password=ahamed;Persist Security Info = True;"
con.Open
i = 10
Do While i > 0

Set cmd = New ADODB.Command
cmd.CommandText = "begin ins_emp_with_para(?,?,?,?); end;"
cmd.ActiveConnection = con
Set p1 = cmd.CreateParameter("P1", adInteger, adParamInput, 8, i)
Set p2 = cmd.CreateParameter("p2", adLongVarChar, adParamInput, 30, "Ahamed")
Set p3 = cmd.CreateParameter("p3", adInteger, adParamInput, 8, 3)
Set p4 = cmd.CreateParameter("p4", adLongVarChar, adParamInput, 30, "Software")
cmd.Parameters.Append p1
cmd.Parameters.Append p2
cmd.Parameters.Append p3
cmd.Parameters.Append p4
cmd.Execute
i = i - 1
Loop

con.Close
MsgBox "Data been successfully Uploaded", vbInformation + vbOKOnly, "Health Check"

End Sub




To Commit or Rollback transaction:-

Syntax:-

Connection.BeginTrans
Connection.Execute(Insert sql statement)
Connection.Execute(Insert sql statement)
Connection.Execute(Insert sql statement)
Connection.Execute(Insert sql statement)
Connection.Execute(Insert sql statement)
Connection.CommitTrans
On Error
Connection.RollbackTrans

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

Send mail using VBA

Sub sendmessagetouser()
Const Outlookmailitem As Integer = 0
Set OutlookApp = CreateObject("Outlook.Application")
Set outlookmail = OutlookApp.createitem(Outlookmailitem)
outlookmail.Display
outlookMail.From = "manzoor.ahamed@test.com"
outlookmail.To = "manzoor.ahamed@test.com"
outlookmail.Subject = "Test Message"
outlookmail.Body = "Hello " & Application.UserName & " This is a test"
outlookmail.attachments.Add "E:\testfile.txt"
outlookmail.Send
End Sub

Examples for using files

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("E:\HKA_REPORT_TEMP")
k = f.Files.Count 'Get file count in a folder

-- Read from one file and write it to the other

Set ifs = fs.opentextfile("E:\input.sql")
Set a = fs.CreateTextFile("E:\output.sql", True)
a.WriteLine "This is test:
Do Until ifs.atendofstream
tt = ifs.readline
a.WriteLine tt
Loop
a.Close
ifs.Close

-- Copy files from one location to other
Set f = fs.GetFolder("E:\FILEFOLER")
Set fc = f.Files
For Each f1 In fc
s = f1.Name
FileCopy f1, "E:\APPLN\" & s
f1.Delete
Next

----Automate using vb script---
Dim args, objExcel
Set args = WScript.Arguments
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open "E:\HKA_REPORT\TABLESPACE_REPORT.xlsm"
objExcel.Visible = True
objExcel.Run "extractreport"
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Quit
-------------------------------------------------------

Script to change the colour of the cell which contains data.
Sub TestForDups()

Dim LLoop As Integer
Dim LTestLoop As Integer
Dim LClearRange As String
Dim Lrows As Integer
Dim LRange As String
Dim LChangedValue As String
Dim LTestValue As String

'Test first 200 rows in spreadsheet for uniqueness
Lrows = 200
LLoop = 2

'Clear all flags
LClearRange = "A2:A" & Lrows
Range(LClearRange).Interior.ColorIndex = xlNone
'Check first 200 rows in spreadsheet
While LLoop <= Lrows
LChangedValue = "A" & CStr(LLoop)
If Len(Range(LChangedValue).Value) > 0 Then
'Test each value for uniqueness
LTestLoop = 2
While LTestLoop <= Lrows
If LLoop <> LTestLoop Then
LTestValue = "A" & CStr(LTestLoop)
'Value has been duplicated in another cell
If Range(LChangedValue).Value = Range(LTestValue).Value Then
'Set the background color to red
Range(LChangedValue).Interior.ColorIndex = 3
Range(LTestValue).Interior.ColorIndex = 3
End If
End If
LTestLoop = LTestLoop + 1
Wend
End If
LLoop = LLoop + 1
Wend
End Sub
-------------------------

simple folder creation script:-

Sub test()
Dim fs, f, s
m = "e:\thisisa test folder"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.createfolder(m)
s = f.DateCreated
MsgBox s
End Sub

-------
Help on VBA Site
http://www.ozgrid.com/VBA