(Solved) – The Outlook VBA script sends the selected data to the SQL database


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
    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
    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 Files7-Zip7z.exe"
If Not FileExists(PathZipProgram) Then
    PathZipProgram = "C:Program Files (x86)7-Zip7z.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 & "Zipattachment.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)

strstrFilePath = Environ("appdata") & _
    "MicrosoftSignatures" & cstrFileSigntature
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = _
    objFSO.GetFile(cstrFileSigntature).OpenAsTextStream(1, -2)
strSignature = objTextStream.ReadAll

'clear variables
Set objTextStream = Nothing
Set objFSO = Nothing

Set objNewMail1 = Application.CreateItem(olMailItem)

With objNewMail1
    For Each recip In objMail.Recipients
        Set newRecip = .Recipients.Add(recip.Address)
        newRecip.Type = recip.Type
    .Subject = strSubject
    .BodyFormat = olFormatHTML
    .HTMLBody = strSignature
    .Attachments.Add cstrFolderAttachment & "Zipattachment.zip"
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


For i = 1 To Lenght
    If i Mod 2 = 0 Then
        strPassword = Chr(Int((90 - 65   1) * Rnd   65)) & strPassword 
        strPassword = Int((9 * Rnd)   1) & strPassword 
    End If
Next i

RandomPassword = strPassword 

End Function

Database structure:

date_create DATETIME NOT NULL,
file_size INT NOT NULL

Leave a Reply

Your email address will not be published. Required fields are marked *