Hi everyone,
I am using a Macro in Outlook, to send emails with different attachment to different people. This macro works fine on my computer, but it doesn't work on my colleague one.
I’m using Outlook 2013 with 32bit and my colleague have upgraded his computer to 64bit.
I’m asking for your help to make this macro work on a 64 bit computer.
Here is the code I use:
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Function MyShowOpenFile() As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
'OpenFile.hwndOwner = parentform.Zoom
sFilter = "Excel 2003 Files (*.xls)"
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrTitle = "Select a file using the Common Dialog DLL"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
MsgBox "A file was not selected!", vbInformation, _
"Select a file using the Common Dialog DLL"
MyShowOpenFile = ""
Else
MyShowOpenFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
Private Function QuotedIdentifier(Name As Variant) As String
If IsNull(Name) Then
QuotedIdentifier = ""
Else
QuotedIdentifier = "[" & Name & "]"
End If
End Function
Private Sub cmdSelectieFisierSursa_Click()
On Error GoTo hErr
txtFisierSursa.Text = MyShowOpenFile()
If txtFisierSursa.Text <> "" And MsgBox("Este inchis fisierul " & txtFisierSursa.Text & " ?" & vbCrLf & vbCrLf & "Fisierul trebuie inchis inainte de a fi procesat.", vbYesNo + vbQuestion) = vbYes Then
Dim adoCon As ADODB.Connection
Set adoCon = New ADODB.Connection
adoCon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtFisierSursa.Text & ";Extended Properties=""Excel 8.0;HDR=Yes"""
adoCon.Open
Dim adoRSSchema As ADODB.Recordset
Set adoRSSchema = adoCon.OpenSchema(adSchemaTables)
cmbWorksheet.Clear
While Not adoRSSchema.EOF
cmbWorksheet.AddItem IIf(Not IsNull(adoRSSchema.Fields("TABLE_SCHEMA").Value), QuotedIdentifier(adoRSSchema.Fields("TABLE_SCHEMA")) & ".", "") & QuotedIdentifier(adoRSSchema.Fields("TABLE_NAME"))
adoRSSchema.MoveNext
Wend
adoCon.Close
End If
Exit Sub
hErr:
MsgBox "Eroare:" & vbCrLf & Err.Description
End Sub
Private Function NZ(Value As Variant) As String
NZ = IIf(IsNull(Value), "", Value)
End Function
Private Sub cmdTrimite_Click()
On Error GoTo hErr
If cmbWorksheet.ListIndex >= 0 Then
Dim adoCon As ADODB.Connection
Set adoCon = New ADODB.Connection
adoCon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtFisierSursa.Text & ";Extended Properties=""Excel 8.0;HDR=Yes"""
adoCon.Open
Dim adoRS As ADODB.Recordset
Set adoRS = adoCon.Execute("SELECT * FROM " & cmbWorksheet.List(cmbWorksheet.ListIndex))
Dim index As Integer, count As String, step As Byte
index = 1
count = lblNrInregistrari.Caption
step = 1
Dim app As Outlook.Application
Set app = ActiveWindow.Application
While Not adoRS.EOF
Dim campCode As String, campTo As String, campCC As String, campBCC As String, campAt1 As String, campAt2 As String, campAt3 As String, campAt4 As String, campAt5 As String
step = 2
campCode = NZ(adoRS.Fields("Code"))
campTo = NZ(adoRS.Fields("To"))
campCC = NZ(adoRS.Fields("CC"))
campBCC = NZ(adoRS.Fields("BCC"))
campAt1 = NZ(adoRS.Fields("At1"))
campAt2 = NZ(adoRS.Fields("At2"))
campAt3 = NZ(adoRS.Fields("At3"))
campAt4 = NZ(adoRS.Fields("At3"))
campAt5 = NZ(adoRS.Fields("At5"))
Debug.Print campCode, campTo, campCC, campBCC, campAt1, campAt2, campAt3, campAt4, campAt5
step = 3
Dim msj As Outlook.MailItem
step = 4
Set msj = app.CreateItem(olMailItem)
step = 5
msj.To = campTo
msj.CC = campCC
msj.BCC = campBCC
msj.Subject = txtSubiect.Text
msj.BodyFormat = olFormatPlain
msj.Body = txtMesaj.Text
step = 6
If campAt1 <> "" Then
msj.Attachments.Add campAt1, olByValue
End If
If campAt2 <> "" Then
msj.Attachments.Add campAt2, olByValue
End If
If campAt3 <> "" Then
msj.Attachments.Add campAt3, olByValue
End If
step = 7
msj.Send
lblStatusTrimitereEmail.Caption = index & " / " & count
step = 9
adoRS.MoveNext
index = index + 1
Wend
step = 10
adoRS.Close
Set adoRS = Nothing
adoCon.Close
Set adoCon = Nothing
Else
MsgBox "Selectati fisierul Excel (*.xls) si tabelul pe care doriti sa-l procesati.", vbInformation
End If
Exit Sub
hErr:
Dim customErr As String
customErr = "Step=" & step & ", " & GetCustomErrorDescription(step)
Dim cale As String
cale = Mid(txtFisierSursa.Text, 1, InStrRev(txtFisierSursa.Text, "\"))
Dim id As Integer
id = FreeFile
Open cale & "Results.csv" For Append As #id
Write #1, campCode & ";" & """Eroare trimitere:" & customErr
Close #id
MsgBox "Eroare:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & customErr & vbCrLf & vbCrLf & "Email Code=" & campCode
If MsgBox("Doriti sa continuati cu trimiterea mesajelor ?", vbYesNo) = vbYes Then
Resume
End If
End Sub
Private Function GetCustomErrorDescription(step As Byte) As String
Select Case step
Case 1
GetCustomErrorDescription = "Outlook.Application"
Case 2
GetCustomErrorDescription = "NZ (adoRS.Fields(Camp))"
Case 3
GetCustomErrorDescription = "Dim msj As Outlook.MailItem"
Case 4
GetCustomErrorDescription = "Set msj = app.CreateItem(olMailItem)"
Case 5
GetCustomErrorDescription = "msj.Camp = variabilaCamp"
Case 6
GetCustomErrorDescription = "msj.Attachments.Add"
Case 7
GetCustomErrorDescription = "msj.Send"
Case 8
GetCustomErrorDescription = "adoRS.Fields(Result) = OK"
Case 9
GetCustomErrorDescription = "adoRS.MoveNext"
Case 10
GetCustomErrorDescription = "adoRS.Close"
Case Else
GetCustomErrorDescription = "?"
End Select
End Function
Private Sub cmbWorksheet_Click()
On Error GoTo hErr
If cmbWorksheet.ListIndex >= 0 Then
Dim adoCon As ADODB.Connection
Set adoCon = New ADODB.Connection
adoCon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtFisierSursa.Text & ";Extended Properties=""Excel 8.0;HDR=Yes"""
adoCon.Open
Dim adoRS As ADODB.Recordset
Set adoRS = adoCon.Execute("SELECT COUNT(*) AS Cnt FROM " & cmbWorksheet.List(cmbWorksheet.ListIndex))
If Not adoRS.EOF Then
lblNrInregistrari = adoRS.Fields("Cnt")
Else
lblNrInregistrari = "#Err"
End If
adoCon.Close
Else
MsgBox "Selectati fisierul Excel (*.xls).", vbInformation
End If
Exit Sub
hErr:
MsgBox "Eroare:" & vbCrLf & Err.Description
End Sub
Thank you all in advance.
Reply With Quote
