Сценарий Outlook VBA отправляет выбранные данные в базу данных SQL - PullRequest
Новая
       13

Сценарий Outlook VBA отправляет выбранные данные в базу данных SQL

0 голосов
/ 23 марта 2020

У меня есть простой сценарий VBA в Outlook 2019, сценарий архивирует вложение перед отправкой электронного письма, создает новое электронное письмо, прикрепляет вложение и отправляет его получателю. Моя цель - сохранить выбранные данные в базу данных SQL, например, .To, From и zip-архив в двоичном формате attachment.zip. У меня проблема с поиском команды для отправки INSERT INTO в базу данных, есть ли такая возможность?

Сценарий VBA: 

#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

Функция завершения

Структура базы данных: 

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
...