The Outlook VBA script sends the selected data to the SQL database - sql-server

I have a simple VBA script in Outlook 2019, script zips an attachment before sending an email, creates a new email, attaches an attachment, and sends it to the recipient. My goal is to save selected data to SQL database, Such as .To,From and zip archive as binaryattachment.zip. I have a problem finding a command to send INSERT INTO to the database, is there such a possibility?
VBA script:
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'MS Office 64 Bit
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long) 'MS Office 32 Bit
#End If
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExists = False
Else
FileExists = True
End If
End Function
Sub MainFunction()
Const cstrFolderAttachment As String = "C:\attachments\"
'Test 32/64 bit
Dim PathZipProgram As String
PathZipProgram = "C:\Program Files\7-Zip\7z.exe"
If Not FileExists(PathZipProgram) Then
PathZipProgram = "C:\Program Files (x86)\7-Zip\7z.exe"
End If
'Password lenght
Const cintLenghtPassword As Integer = 8
'User signature file
Const cstrFileSigntature As String = "signature.htm"
Dim objMail As Outlook.MailItem
Dim objNewMail1 As Outlook.MailItem
Dim objNewMail2 As Outlook.MailItem
Dim objAttachment As Attachment
Dim objWord As Object
Dim objDocument As Object
Dim objFSO As Object
Dim objTextStream As Object
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim strCommand As String
Dim strFilePath As String
Dim objWordRange As Object
Dim strMessage As String
Dim objApp As Object
Dim objInsp As Object
'Set objApp = GetObject("", "Outlook.Application")
'Set objInsp = objApp.ActiveInspector.CurrentItem
Dim signature As String
Dim objNS As Outlook.NameSpace
Dim objFolderItem As Outlook.Folder
Select Case Application.ActiveWindow.Class
Case olExplorer
Set objMail = ActiveExplorer.Selection.Item(1)
Case olInspector
Set objMail = ActiveInspector.CurrentItem
End Select
strMessage = "Subject: " & objMail.Subject & vbCrLf & vbCrLf & "Message: " & vbCrLf & objMail.Body
'Clear subfolder
On Error Resume Next
Kill cstrFolderAttachment & "*.*"
Kill cstrFolderAttachment & "Zip\*.*"
On Error GoTo 0
Set objMail = Application.ActiveInspector.CurrentItem
Set objNS = Application.GetNamespace("MAPI")
Set objFolderItem = objNS.Folders.Item("name.surname#domaind.com").Folders.Item("Temp")
objMail.Move objFolderItem
objDokument.Close False
'clear variables
Set objDokument = Nothing
Set objWord = Nothing
'save all attechments to folder
For Each objAttachment In objMail.Attachments
objAttachment.SaveAsFile cstrFolderAttachment & objAttachment.FileName
Next objAttachment
'7zip comprimation
strSource = cstrFolderAttachment & "*.*"
strDestination = cstrFolderAttachment & "Zip\attachment.zip"
strPassword = RandomPassword(cintLenghtPassword)
strCommand = """" & PathZipProgram & """ a -tzip """ & strCil & _
""" -p" & strPassword & " """ & strSource & """"
Shell strCommand
'Application.Wait (Now + TimeSerial(0, 0, cintBreak))
Call Sleep(1000 * cintBreak)
'FSO
strstrFilePath = Environ("appdata") & _
"\Microsoft\Signatures\" & cstrFileSigntature
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = _
objFSO.GetFile(cstrFileSigntature).OpenAsTextStream(1, -2)
strSignature = objTextStream.ReadAll
objTextStream.Close
'clear variables
Set objTextStream = Nothing
Set objFSO = Nothing
Set objNewMail1 = Application.CreateItem(olMailItem)
With objNewMail1
'To
For Each recip In objMail.Recipients
Set newRecip = .Recipients.Add(recip.Address)
newRecip.Type = recip.Type
Next
.Subject = strSubject
.BodyFormat = olFormatHTML
.HTMLBody = strSignature
.Attachments.Add cstrFolderAttachment & "Zip\attachment.zip"
.Display
.Send
End With
objNewMail1.Close olSave
'clear variables
Set objMail = Nothing
Set objNewMail1 = Nothing
i = MsgBox("Email sended.", , "info box")
End Sub
Private Function RandomPassword(Delka As Integer)
'Dave Hawley
Dim i As Integer
Dim strHeslo As String
Randomize
For i = 1 To Lenght
If i Mod 2 = 0 Then
strPassword = Chr(Int((90 - 65 + 1) * Rnd + 65)) & strPassword
Else
strPassword = Int((9 * Rnd) + 1) & strPassword
End If
Next i
RandomPassword = strPassword
End Function
Database structure:
ID INT NOT NULL IDENTITY(1,1) PRIMARY KEY,
to_email VARCHAR(100) NOT NULL,
from_email VARCHAR(100) NOT NULL,
attachment VARBINARY(MAX) NOT NULL,
date_create DATETIME NOT NULL,
file_size INT NOT NULL

Related

Autofilter with .Sheets(Array)

This is my first post on Stack Overflow.
I have an Excel file that contains multiple sheets with data. Sheet "Emailer" contains buttons to hit the macro. The macro is working fine, while running it copies the defined sheets into new workbook and create an outlook email with attachment.
All is working fine, I would need a filter on a specific column to filter the data before copy and past into new workbook. Currently, all the data with no filter is copying. The specific column (M) is available in all 4 sheets that I want to filter (basis the value available under it) and copy paste.
Below is my code i am struggling with to achieve what i want.
Request to help and applgoies if i havent follow any rule of posting the question.
Thansk in advance.
Sub MIS_Mail()
Dim rng As Range
Dim rng2 As Range
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim StrSignature As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Set ws = Sheets("Emailer")
Set ws2 = Sheets("GROW MONEY")
Set rng = Nothing
'Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = ws2.Range("A2:M34").SpecialCells(xlCellTypeVisible)
'Set rng2 = ws2.Range("B18:I33").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).Copy ' here i want to filter the data in all three sheets before copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name
strBody = "<font face=""Calibri"" size=""2"" color=""#1F497D"">" & "Dear All," & "<br> <br>" & _
"Please find attached MIS Report as on " & Format(ws2.Range("B1").Value, "DD-MMM-YY") & "." & "<br><br>" & "</font>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ws.Range("C5").Value
.CC = ws.Range("D5").Value
.BCC = ""
.Subject = ws.Range("E5").Value
.HTMLBody = strBody & RangetoHTML(rng) '& RangetoHTML2(rng2) & vbNewLine '& StrSignature '& Signature
.Attachments.Add Destwb.FullName
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function RangetoHTML2(rng2 As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng2.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.readall
ts.Close
RangetoHTML2 = Replace(RangetoHTML2, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I have tried to do something with Autofilter with array() but not luckm here is the edited code:
Sub MIS_Mail()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim rng2 As Range
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim StrSignature As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim CatSites As String
Set ws = Sheets("Emailer")
Set ws2 = Sheets("GROW MONEY")
Set rng = Nothing
'Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = ws2.Range("A2:M50").SpecialCells(xlCellTypeVisible)
'Set rng2 = ws2.Range("B18:I33").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
CatSites = "GROW"
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).AutoFilter
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).AutoFilter field:=13, Criteria1:=CatSites
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).SpecialCells(xlCellTypeVisible).Copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name
strBody = "<font face=""Calibri"" size=""2"" color=""#1F497D"">" & "Dear All," & "<br> <br>" & _
"Please find attached MIS Report as on " & Format(ws2.Range("B1").Value, "DD-MMM-YY") & "." & "<br><br>" & "</font>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ws.Range("C2").Value
.CC = ws.Range("D2").Value
.BCC = ""
.Subject = ws.Range("E2").Value
.HTMLBody = strBody & RangetoHTML(rng) '& RangetoHTML2(rng2) & vbNewLine '& StrSignature '& Signature
.Attachments.Add Destwb.FullName
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
You could work with similar code as later in your Sub (usually not needed to post your entire sub if it's this long, just the bit you're struggling with)
Sub MIS_Mail()
Dim rng As Range, rng2 As Range
Dim ws As Worksheet, ws2 As Worksheet, sh As Worksheet, nsh As Worksheet
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim StrSignature As String, FileExtStr As String, TempFilePath As String, TempFileName As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, Destwb As Workbook
Dim TheActiveWindow As Window, TempWindow As Window
Dim shArray As Variant, arrSheet As Variant
Set ws = Sheets("Emailer")
Set ws2 = Sheets("GROW MONEY")
Set rng = Nothing
'Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = ws2.Range("A2:M34").SpecialCells(xlCellTypeVisible)
'Set rng2 = ws2.Range("B18:I33").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sourcewb = ActiveWorkbook 'easier to declare these to copy the sheets while going through the for each loop after filtering them
Set Destwb = Workbooks.Add
Sourcewb.Activate
shArray = Array(Sheets("Tranche wise details"), Sheets("All products Deal limit status"), Sheets("Delinquency"), Sheets("GROW MONEY"))
For Each arrSheet In shArray 'Filter before you do the copying
Set sh = arrSheet
Set nsh = Destwb.Sheets.Add
nsh.Name = sh.Name
If sh.AutoFilterMode Then 'autofilter is 'on'
On Error Resume Next
sh.ShowAllData 'clearing existing filters
sh.Columns("M:M").Copy 'getting rid of the formulas first
sh.Columns("M:M").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO"
On Error GoTo 0
Else
sh.Columns("A:A").Copy
sh.Columns("A:A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO" 'still not getting any errors here on the testfile
End If
sh.UsedRange.Copy nsh.Range("A1")
nsh.UsedRange.Copy
nsh.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next arrSheet
Application.DisplayAlerts = False
Destwb.Sheets(Destwb.Sheets.Count).Delete 'delete the sheet the workbook started with (depending on the language, these differ)
Application.DisplayAlerts = True
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
Application.CutCopyMode = False
Destwb.Activate 'Destwb is ready to be mailed"
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name
strBody = "<font face=""Calibri"" size=""2"" color=""#1F497D"">" & "Dear All," & "<br> <br>" & _
"Please find attached MIS Report as on " & Format(ws2.Range("B1").Value, "DD-MMM-YY") & "." & "<br><br>" & "</font>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ws.Range("C5").Value
.CC = ws.Range("D5").Value
.BCC = ""
.Subject = ws.Range("E5").Value
.HTMLBody = strBody & RangetoHTML(rng) '& RangetoHTML2(rng2) & vbNewLine '& StrSignature '& Signature
.Attachments.Add Destwb.FullName
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function RangetoHTML2(rng2 As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng2.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.readall
ts.Close
RangetoHTML2 = Replace(RangetoHTML2, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
My Test Sub: ONLY USED ON YOUR TESTFILE, THIS IS NOT THE FULL SUB
Sub TESTMIS_Mail()
Dim rng As Range, rng2 As Range
Dim ws As Worksheet, ws2 As Worksheet, sh As Worksheet, nsh As Worksheet
Dim StrSignature As String, FileExtStr As String, TempFilePath As String, TempFileName As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, Destwb As Workbook
Dim TheActiveWindow As Window, TempWindow As Window
Dim shArray As Variant, arrSheet As Variant
Set Sourcewb = ActiveWorkbook
Set Destwb = Workbooks.Add
Sourcewb.Activate
shArray = Array(Sheets("Tranche wise details"), Sheets("All products Deal limit status"), Sheets("Delinquency"), Sheets("GROW MONEY"))
For Each arrSheet In shArray 'Filter before you do the copying
Set sh = arrSheet
Set nsh = Destwb.Sheets.Add
nsh.Name = sh.Name
If sh.AutoFilterMode Then 'autofilter is 'on'
On Error Resume Next
sh.ShowAllData 'clearing existing filters
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO"
On Error GoTo 0
Else
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO"
End If
sh.UsedRange.Copy nsh.Range("A1")
nsh.UsedRange.Copy
nsh.Range("A1").PasteSpecial xlPasteValues
Next arrSheet
Application.DisplayAlerts = False
Destwb.Sheets(Destwb.Sheets.Count).Delete
Application.DisplayAlerts = True
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
Application.CutCopyMode = False
Destwb.Activate
End Sub
Hope this is what you were looking for.

Search multiple strings in a excel workbook

I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter

VBA Update column in SQL Server table with data from excel

I have a excel workbook that pulls data into a table users can then fill in the missing dates in column 11. Column 1 is the unique identifier that matches the ID column in the SQL table. I want to create a macro that runs when the workbook is closed and will update the SQL table with the filled in dates, but I am struggling with the code. I have have tried two different things but neither seem to work.
Option 1:
Private Sub tableupdate()
Dim con As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rst As New ADODB.Recordset
Dim i As Long
Dim vDB As Variant
Dim ws As Worksheet
con.connectionstring = "Provider=SQLOLEDB;Password=*********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
con.Open
Set cmd.ActiveConnection = con
Set ws = ActiveSheet
vDB = ws.Range("A4").CurrentRegion
For i = 2 To UBound(vDB, 1)
cmd.CommandText = "UPDATE [dbo].[all_load_control] set Driver_arr_dte = ' " & vDB(i, 2) & " ' WHERE mst_ship_num = ' " & vDB(i, 1) & " ' "
cmd.Execute
Next i
con.Close
Set con = Nothing
End Sub
option 2:
Private Sub uplodblanks()
Dim r, c, con, dstring
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim lRow
Dim ssql As String
con = "Provider=SQLOLEDB;Password=********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
r = 1
c = 1
Worksheets("WTUpload").Calculate
lRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
cn.Open con
i = 1
For i = 1 To lRow
ssql = "update dbo.cxu_all_load_control set driver_arr_dte = " & CDate(Sheets("WTUpload").Cells(i, 11)) & " where mst_ship_num = " & CDbl(Sheets("WTUpload").Cells(i, 11)) & " ; "
cn.Execute ssql
Next i
cn.Close
End Sub
Any help as to why neither of these are working would be great
Replace the mydbConnect() function with you own method of getting a connection.
Sub tableupdate2()
Const COL_NUM As String = "A"
Const COL_DATE As String = "K"
Const TABLE As String = "dbo.all_load_control"
' define update sql
Const SQL As String = " UPDATE " & TABLE & _
" SET Driver_arr_dte = CAST(? AS DATETIME2) " & _
" WHERE mst_ship_num = ? "
' establish connection and create command object
Dim con As Object, cmd As Object, sSQL As String
Set con = mydbConnect() ' establish connection
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = con
.CommandText = SQL
.CommandType = 1 'adCmdText
.Parameters.Append .CreateParameter("P1", adVarChar, 1, 20) '
.Parameters.Append .CreateParameter("P2", adVarChar, 1, 50) ' adParamInput = 1
End With
' prepare to get data from spreadsheet
Dim wb As Workbook, ws As Worksheet, iLast As Integer, iRow As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("WTUpload")
iLast = ws.Range(COL_NUM & Rows.count).End(xlUp).Row
Dim p1 As String, p2 As String, count As Long
' scan sheet and update db
Debug.Print "Updates " & Now
With cmd
For iRow = 1 To iLast
p1 = Format(ws.Range(COL_DATE & iRow).Value, "yyyy-mm-dd hh:mm")
p2 = ws.Range(COL_NUM & iRow).Value
If len(p2) > 0 Then
.Parameters(0).Value = p1
.Parameters(1).Value = p2
Debug.Print "Row ", iRow, "p1=" & p1, "P2=" & p2
.Execute
count = count + 1
End If
Next
End With
' end
MsgBox "Rows processed = " & count, vbInformation, "Updates Complete"
con.Close
Set con = Nothing
End Sub
Edit - added connection and test code
Function mydbConnect() As Object
Dim sConStr As String
sConStr = "Provider=SQLOLEDB;Password=*********;User ID=clx_write;" & _
"Initial Catalog=DPEDataMartDBPrd01;" & _
"Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
Set mydbConnect = CreateObject("ADODB.Connection")
mydbConnect.Open sConStr
End Function
Sub test()
Dim con As Object, rs As Object
Set con = mydbConnect()
Set rs = con.Execute("SELECT CURRENT_TIMESTAMP")
MsgBox rs.Fields(0), vbInformation, "Current Date/Time"
End Sub

vbs read from file and parse it to the batch file

I had a script which worked on win xp but beacuse some of the methods are not available anymore I had to rewrite the script and use mshta.exe.
VBS script should do two things:
Read from file
Parse the info to the batch file
I have done the 1st bit but in the 2nd part I am getting an error. Could you please point me to the right direction?
Option Explicit
Dim objFso
Dim strFileName
Dim strFile
Dim objShell
Dim cimv2
Dim RemoteMachine
Dim YesNo
Dim out
Dim crt
Dim objDialog, intResult
Dim objTextFile, strText, iintresult
Dim objExec, strMSHTA, wshShell
mainMenu
Sub mainMenu()
do
out = inputbox("Choose option:" & vbcr & "1 - Deployment" & vbcr & "0 - Exit", "Menu", "0")
If out="1" then
call SelectFile
End If
If out="0"
then WScript.Quit
End if
loop
End Sub
Sub bgInfo(param)
YesNo = Msgbox("deployment? " & param, 4)
if YesNo = vbYes Then
do while not strMSHTA.AtEndOfStream
RemoteMachine = strMSHTA.ReadLine()
On Error Resume Next
objShell.Run "bginfo.bat " & RemoteMachine, 1, true
On Error Goto 0
loop
end if
End Sub
Sub SelectFile( )
strMSHTA = "mshta.exe ""about:" & "<" & "input type=file id=FILE>" _
& "<" & "script>FILE.click();new ActiveXObject('Scripting.FileSystemObject')" _
& ".GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);" & "<" & "/script>"""
Set wshShell = CreateObject( "WScript.Shell" )
Set objExec = wshShell.Exec( strMSHTA )
intResult = objExec.StdOut.ReadLine( )
msgbox iintresult
If intResult <> "" Then
call bgInfo(intResult)
End If
Set objExec = Nothing
Set wshShell = Nothing
End Sub
Set objFso = Nothing
Set strFileName = Nothing
Set strFile = Nothing
Set objShell = Nothing
Set cimv2 = Nothing
Set RemoteMachine = Nothing
Set fso = Nothing
I am getting an error in line 33 char 5
Error: Object required: strMSHTA
thank you! :)
I had to add this code:
Set objFso = CreateObject("Scripting.FileSystemObject")
set strFile = objFso.OpenTextFile(param2, 1, True)
Set objShell = WScript.CreateObject("Wscript.Shell")`

If Then not working

I've searched a lot about this problem, but I haven't found anything specific to this case. I'm trying to run a script that grabs all hosts from AD, then checks each one for a specific file. Two txt files are created, one with and one without. The problem I'm having is that all host names are added to the 'without' file and the 'with' file is empty, but I know for a fact that both lists should have hosts listed. I know the loop is working because all the host names are listed, but it fails to apply the if/then check. I apologize for the crudity of my script, I'm VERY new to this. I would GREATLY appreciate any tips...
Const ADS_SCOPE_SUBTREE = 2
Dim cn
Set cn = CreateObject("ADODB.Connection")
cn.Provider = "ADsDSOObject"
cn.Open "Active Directory Provider"
Dim cmd
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = cn
Dim ou
ou = "DC=mydomain,DC=COM"
cmd.CommandText = "SELECT name " & _
"FROM 'LDAP://" & ou & "' " & _
"WHERE objectClass='computer' " & _
"ORDER BY name"
cmd.Properties("Page Size") = 1000
cmd.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Const ForAppending = 8
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim yesFile
Set yesFile = fso.OpenTextFile("pcswithsw.txt", ForAppending, True)
Dim noFile
Set noFile = fso.OpenTextFile("pcswithoutsw.txt", ForAppending, True)
Dim rs
Set rs = cmd.Execute
strComputer = rs(0)
rs.MoveFirst
Do Until rs.EOF
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery("Select * From CIM_DataFile Where Name = 'C:\\somefile.exe'")
If colFiles.Count = 0 Then
noFile.WriteLine rs(0)
Else
yesFile.WriteLine rs(0)
End If
rs.MoveNext
Loop
yesFile.Close
noFile.Close
Set yesFile = Nothing
Set noFile = Nothing
Set fso = Nothing
Figured it out finally. I loaded the list of hosts into an array, then fed the array to the If/Then statement. It runs slowly, but the majority of the processing time is the script waiting for non-existent hosts to reply (need to clean up AD).
Const ADS_SCOPE_SUBTREE = 2
Const ForAppending = 8
Dim hostArray()
Dim cn
Set cn = CreateObject("ADODB.Connection")
cn.Provider = "ADsDSOObject"
cn.Open "Active Directory Provider"
Dim cmd
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = cn
Dim ou
ou = "DC=mydomain,DC=COM"
cmd.CommandText = "SELECT name " & _
"FROM 'LDAP://" & ou & "' " & _
"WHERE objectClass='computer' " & _
"ORDER BY name"
cmd.Properties("Page Size") = 1000
cmd.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim outFile
Set outFile = fso.OpenTextFile("computers.txt", ForAppending, True)
Dim yesFile
Set yesFile = fso.OpenTextFile("pcswithsw.txt", ForAppending, True)
Dim noFile
Set noFile = fso.OpenTextFile("pcswithoutsw.txt", ForAppending, True)
Dim j
j=0
Dim rs
Set rs = cmd.Execute
rs.MoveFirst
Do Until rs.EOF
REDIM PRESERVE hostArray(j)
for i = 0 to rs.EOF
hostArray(j)=rs(0)
outFile.WriteLine rs(0)
rs.MoveNext
i = i + 1
j = j + 1
next
Loop
For Each strComputer in hostArray
On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery("Select * From CIM_DataFile Where Name = 'C:\\folder\\subfolder\\file.ext'")
If colFiles.Count = 0 Then
noFile.WriteLine strComputer
Else
yesFile.WriteLine strComputer
End If
Next
yesFile.Close
noFile.Close
Set yesFile = Nothing
Set noFile = Nothing
Set fso = Nothing
msgbox("All done")

Resources