Send Access Attachment Field as a CDO Attachment with VBA - vba

I have the following code:
Option Compare Database
Private Sub Command27_Click()
Dim fso, f
Set fso = CreateObject("scripting.FileSystemObject")
Set f = fso.OpenTextFile("M:\Instructor Letter Templates (Typical).htm")
InstructorText = f.ReadAll
f.Close
Set f = Nothing
Set fso = Nothing
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
Dim strWhere As String
Set db = CurrentDb()
sql = "SELECT Classes.ClassID, Grade.GradeID, Instructors.RiosaladoEmail, students.sLastName, students.sFirstName, Grade.Form, Grade.Printout FROM students INNER JOIN (Classes INNER JOIN (Instructors INNER JOIN Grade ON Instructors.InstructorID = Grade.[Instructor]) ON Classes.ClassID = Grade.ClassID) ON students.StudentID = Grade.StudentID WHERE Grade.DateProcessed=Date()"
Set rs = db.OpenRecordset(sql, dbOpenDynaset)
Do Until rs.EOF
Dim Class As String
Dim Grade As String
Dim Email As String
Dim Today As String
Dim sLast As String
Dim sFirst As String
Dim Form As String
Class = rs("ClassID")
Grade = rs("GradeID")
Email = rs("RiosaladoEmail")
sLast = rs("sLastName")
sFirst = rs("sFirstName")
Form = rs("Form")
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2
Const cdoAnonymous = 0
Const cdoBasic = 1
Const cdoNTLM = 2
Set cdomsg = CreateObject("CDO.Message")
cdomsg.Subject = sLast & "," & sFirst & Class & Chr(32) & Form
cdomsg.FROM = "<myemail>"
cdomsg.To = Email
cdomsg.HTMLBody = InstructorText
cdomsg.AddAttachment
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of Remote SMTP Server
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
'Type of authentication, NONE, Basic (Base64 encoded), NTLM
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
'Your UserID on the SMTP server
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = "MyEmail"
'Your password on the SMTP server
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "MyPW"
'Server port (typically 25)
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
'Use SSL for the connection (False or True)
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
'Connection Timeout in seconds (the maximum time CDO will try to establish a connection to the SMTP server)
cdomsg.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
cdomsg.Configuration.Fields.Update
cdomsg.Send
rs.MoveNext
Loop
Set rs = Nothing
Set db = Nothing
End Sub
In the query, the field "Grade.Printout" is an Access attachment field with a file attached to it ... in a table.
I want to use this field with cdomsg.AddAttachment ... I know that if I use "cdomsg.AddAttachment ("")" that I can attach a specific file path ... but I want to use the attachment field within Access.
Or is there a better way to do this? Any suggestions would be awesome, thanks!

The CDO AddAttachment method needs to be given the location of the file to be attached, and it doesn't have any way of recognizing a reference to an Access table/field. Therefore you'll need to save the Access attachment to a temporary location using the SaveToFile method of an Access DAO Field2 object, and then pass the path of that file to the CDO AddAttachment method.

Related

How to update the server name for all ODBC linked SQL Server tables using Access VBA

I need to be able to provide a method to update the server name in all ODBC linked table connections in an Access database. All tables have been migrated out of Access to a SQL Express instance. An option is needed to update all external table links to point from "Localhost\SQLExpress" to a SQL instance on another server. The database name will remain consistent. Only the Server instance name needs to be updated.
I've found examples of how to do this for connections to Access database files and Excel files, but not ODBC connections to SQL Server. One post here pointed out the need to dimension a db object and use it directly instead of trying to use CurrentDb directly. That got me further, but now the code fails with a type conversion when trying to assign the new connection string to the TableDef.
Dim OldServer As String
Dim NewServer As String
Dim OldPath As String
Dim NewPath As String
Dim strPath As String
NewServer = Me.NewServerInstance ' get new Server Instance name from form
OldPath = GetCurrentPath("Version")
'Parse old name from the ODBC connection string
OldServer = Replace(Left(OldPath, InStr(GetCurrentPath("Version"), "UID=") - 2), "ODBC Driver 13 for SQL Server;SERVER=", "")
NewPath = Replace(OldPath, OldServer, NewServer)
If NewServer = OldServer Then
GoTo UpdateInstance_Click_Exit
Else
'update all table connection strings.
'Loop & replace Old server instance with New server instance
Dim Db As DAO.Database
Set Db = CurrentDb
Dim td As DAO.TableDef
For Each td In Db.TableDefs
If (td.Attributes And dbAttachedODBC) = dbAttachedODBC Then
Db.TableDefs(td).Connect = NewPath 'getting a datatype conversion error here...
Db.TableDefs(td).RefreshLink
' MsgBox (db.TableDefs(td).Connect)
End If
Next
End If
The code example is what I came up with. There is a comment indicating the point where a datatype conversion error occurs. I guess I need to know if this is this even possible, or if I am trying to do something that is not possible, or just going about it the wrong way...
We use this code where you call AttachSqlServer with the four arguments needed:
Public Function ConnectionString( _
ByVal Hostname As String, _
ByVal Database As String, _
ByVal Username As String, _
ByVal Password As String) _
As String
' Create ODBC connection string from its variable elements.
' 2016-04-24. Cactus Data ApS, CPH.
Const AzureDomain As String = ".windows.net"
Const OdbcConnect As String = _
"ODBC;" & _
"DRIVER=SQL Server Native Client 11.0;" & _
"Description=Application Name;" & _
"APP=Microsoft? Access;" & _
"SERVER={0};" & _
"DATABASE={1};" & _
"UID={2};" & _
"PWD={3};" & _
"Trusted_Connection={4};"
' Const cstrConnect As String = _
' "ODBC;Driver=SQL Server Native Client 11.0;Server=(localdb)\MSSQLLocalDB;Database=Test;Trusted_Connection=Yes"
Dim FullConnect As String
If Right(Hostname, Len(AzureDomain)) = AzureDomain Then
' Azure SQL connection.
' Append servername to username.
Username = Username & "#" & Split(Hostname)(0)
End If
FullConnect = OdbcConnect
FullConnect = Replace(FullConnect, "{0}", Hostname)
FullConnect = Replace(FullConnect, "{1}", Database)
FullConnect = Replace(FullConnect, "{2}", Username)
FullConnect = Replace(FullConnect, "{3}", Password)
FullConnect = Replace(FullConnect, "{4}", IIf(Username & Password = "", "Yes", "No"))
ConnectionString = FullConnect
End Function
Public Function AttachSqlServer( _
ByVal Hostname As String, _
ByVal Database As String, _
ByVal Username As String, _
ByVal Password As String) _
As Boolean
' Attach all tables linked via ODBC to SQL Server or Azure SQL.
' 2016-04-24. Cactus Data ApS, CPH.
Const cstrDbType As String = "ODBC"
Const cstrAcPrefix As String = "dbo_"
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
Dim strConnect As String
Dim strName As String
On Error GoTo Err_AttachSqlServer
Set dbs = CurrentDb
strConnect = ConnectionString(Hostname, Database, Username, Password)
For Each tdf In dbs.TableDefs
strName = tdf.Name
If Asc(strName) <> Asc("~") Then
If InStr(tdf.Connect, cstrDbType) = 1 Then
If Left(strName, Len(cstrAcPrefix)) = cstrAcPrefix Then
tdf.Name = Mid(strName, Len(cstrAcPrefix) + 1)
End If
tdf.Connect = strConnect
tdf.RefreshLink
Debug.Print Timer, tdf.Name, tdf.SourceTableName, tdf.Connect
DoEvents
End If
End If
Next
For Each qdf In dbs.QueryDefs
If qdf.Connect <> "" Then
Debug.Print Timer, qdf.Name, qdf.Type, qdf.Connect
qdf.Connect = strConnect
End If
Next
Debug.Print "Done!"
AttachSqlServer = True
Exit_AttachSqlServer:
Set tdf = Nothing
Set dbs = Nothing
Exit Function
Err_AttachSqlServer:
' Call ErrorMox
Resume Exit_AttachSqlServer
End Function

Lotus script Lockout users

Sub Initialize
On Error GoTo e
Dim session As New NotesSession, db As NotesDatabase, view As NotesView
Dim nvec As NotesViewEntryCollection
Dim c As integer
Set db = session.currentdatabase
Set view = db.getView("Locked Out Users")
Set nvec = view.Allentries
c = nvec.count
If c > 0 Then
Call nvec.Removeall(true)
' Send notification
Dim sarr(1) As String
sarr(0) = "john.doe#acme.com"
sarr(1) = "foo#acme.com"
Dim mdoc As NotesDocument, rt As notesrichtextitem
Set mdoc = db.createdocument
mdoc.Form = "Memo"
mdoc.Subject = "Removed " + CStr(c) + " Locked out users on mypage"
Set rt = mdoc.Createrichtextitem("Body")
Call rt.Appendtext("Removed " + CStr(c) + " Locked out users")
Call rt.Addnewline(1)
Call rt.Appendtext("Click to open lockout database")
Call rt.Appenddoclink(db,"Lockout")
Call mdoc.Send(False, sarr)
End If
Exit Sub
e:
Print Error,erl
End Sub
I’m a beginner in Lotus Domino it I have some question , It's possible to change this script to delate only locked users with specified name?
I added something like that:
Dim nam As NotesName
Dim c As integer
Set db = session.currentdatabase
Set nam.OrgUnit1 = (“GD”)
Set view = db.getView("Locked Out Users")
Set nvec.OrgUnit1 = view.Allentries
c = nvec.count
If c > 0 Then
In my case I need delete all group person how has specified dc, for example Robert Kowalski/GD/Company everybody how has in name dc=GD?
There are at least 2 ways to achieve your request.
First you can copy the view "Locked Out Users" and change the selection formula to only include your OU.
The other option is something like
dim doc as notesdocument
dim nextDoc as notesdocument
set doc = view.getfirstdocument()
while not doc is nothing
set nextDoc = view.getnextDocument(doc)
set nam = new notesname(doc.getItemValue("[NAMEITEM]")(0))
if strcompare(nam.orgUnit1,"GD",5)=0 then
call doc.remove(true,false)
end if
set doc = nextDoc
wend
Sub Initialize
On Error GoTo e
Dim session As New NotesSession, db As NotesDatabase, view As NotesView
Dim nvec As NotesViewEntryCollection
Dim c As integer
Set db = session.currentdatabase
dim doc as notesdocument
dim nextDoc as notesdocument
set doc = view.getfirstdocument()
while not doc is nothing
set nextDoc = view.getnextDocument(doc)
set nam = new notesname(doc.getItemValue("[NAMEITEM]")(0))
if strcompare(nam.orgUnit1,"GD",5)=0 then
call doc.remove(true,false)
end if
set doc = nextDoc
wend
Set view = db.getView("Locked Out Users")
Set nvec = view.Allentries
c = nvec.count
If c > 0 Then
Call nvec.Removeall(true)
' Send notification
Dim sarr(1) As String
sarr(0) = "john.doe#acme.com"
sarr(1) = "foo#acme.com"
Dim mdoc As NotesDocument, rt As notesrichtextitem
Set mdoc = db.createdocument
mdoc.Form = "Memo"
mdoc.Subject = "Removed " + CStr(c) + " Locked out users on mypage"
Set rt = mdoc.Createrichtextitem("Body")
Call rt.Appendtext("Removed " + CStr(c) + " Locked out users")
Call rt.Addnewline(1)
Call rt.Appendtext("Click to open lockout database")
Call rt.Appenddoclink(db,"Lockout")
Call mdoc.Send(False, sarr)
End If
Exit Sub
e:
Print Error,erl
End Sub
Thank You #umeli for Yours responce. I think now
it should work.

Error on event click + Getting data from database

I'm trying to run an event, but when I run it, I get the error:
The expression On Click you entered as the event property setting
produced the following error: The Expression you entered has a
function containing the wrong number of arguments.
The expression may not result in the name of a macro, the name of a user-defined function, or [Event Procedure].
There may have been an error evaluating the function, even, or macro.
I'd use the following code:
Public Function CH05_Generate(Sagsnr As String)
Dim WordApp As Word.Application
Dim Doc As Word.Document
Dim WordPath As String
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim sql As String
Set db = CurrentDb
sql = "SELECT * FROM Projektdata WHERE Sagsnr Like '" & Sagsnr & "'"
Set rst = db.OpenRecordset(sql, dbOpenDynaset)
WordPath = "My path (Can't show this"
Set WordApp = CreateObject("Word.Application")
Set Doc = WordApp.Documents.Add(WordPath)
With Doc
.FormFields("PName").Result = rst![Projektnavn]
.FormFields("text").Result = Forms![TD-E-PM200-CH05]!Kommentar
.FormFields("S3").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q1
.FormFields("S4").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q2
.FormFields("S5").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q3
.FormFields("S6").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q4
.FormFields("S7").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q5
.FormFields("S8").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q6
.FormFields("S9").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q7
.FormFields("S10").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q8
.FormFields("S11").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q9
.FormFields("S12").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q10
.FormFields("S13").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q11
.FormFields("S14").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q12
.FormFields("S15").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q13
.FormFields("S16").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q14
.FormFields("S17").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q15
.FormFields("S18").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q16
.FormFields("S19").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q17
.FormFields("S20").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q18
.FormFields("S21").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q19
.FormFields("S22").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q20
.FormFields("S23").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q21
.FormFields("S24").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q22
.FormFields("S25").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q23
.FormFields("S26").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q24
.FormFields("S27").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q25
.FormFields("S28").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q26
.FormFields("S29").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q27
.FormFields("S30").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q28
.FormFields("S31").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q29
.FormFields("S32").Result = Forms![TD-E-PM200-CH05]!sub.Form!Q30
.FormFields("S33").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q31
.FormFields("S34").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q32
.FormFields("S35").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q33
.FormFields("S36").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q34
.FormFields("S37").CheckBox.Value = Forms![TD-E-PM200-CH05]!sub.Form!Q35
End With
WordApp.visible = True
WordApp.Activate
WordApp.ActiveDocument.Protect wdAllowOnlyFormFields, True
End Function
What I want to achieve to get data from the "Projektdata" database, and get the correct data, "Projektnavn", to fill out:
.FormFields("PName").Result = rst![Projektnavn]
My database structure is like this:
"SELECT *
FROM dbo.Projektdata p
JOIN dbo.Items i ON p.Sagsnr = i.Sagsnr
WHERE ItemID =" & ItemID & " AND p.Sagsnr Like '" & Sagsnr & "'" -- change "," to AND
I call my function like this: =CH05_Generate()
Public Function CH05_Generate(Sagsnr As String, ItemID As String)
This cannot work - the function expects two parameters, you need to pass them in the function call.

Chinese filename as an attachment in email

Following is simple code to send the mail with an attachment:
/**************************************************/
Dim msgMail As New System.Web.Mail.MailMessage
Dim rcpName As String
Dim client As New SmtpClient
Dim i As Integer
Dim recips_addr() As String = Split(to_address, ";")
Dim recips_name() As String = Split(to_name, ";")
For i = 0 To recips_addr.Length - 1
rcpName = """" & recips_name(i) & """"
msgMail.To = rcpName & recips_addr(i) & ";"
Next
msgMail.From = from_address
msgMail.Subject = subject
msgMail.BodyFormat = System.Web.Mail.MailFormat.Html
msgMail.Body = message
msgMail.BodyEncoding = System.Text.Encoding.UTF8
If String.IsNullOrEmpty(attachment_path) Then attachment_path = "NONE"
If (attachment_path <> "NONE") Then
Dim att As New System.Web.Mail.MailAttachment(attachment_path)
msgMail.Attachments.Add(att)
End If
If send_to_sender Then
msgMail.Bcc = from_address
End If
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = My.Settings.smtp_Server
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = My.Settings.emailUsername
msgMail.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = My.Settings.emailPassword
System.Web.Mail.SmtpMail.Send(msgMail)
/**************************************************/
Now, the query is when i send a pdf file as an attachment using above code and file name is 'Report_出生地_出生地_出生地_6023.pdf'.
when i get the mail in my inbox the name of the file becomes 'Report____6023.pdf'.
I don't know why attachment filenames are changing.
Please help !!!!

Unable write to SQL from VBA/Excel using ADO

I'm using VBA for working with SQL database, Select commands forking fine, problem is with modification of dbase - insert, delete. If I using external application for work with DBase, everything is OK, thats mean - my privilegs is OK. On example Select is done successfully, rest not...
Thanks for your help.
JB
Public LinkID As ADODB.Connection
Public QueryID As ADODB.Recordset
Private Record() As String
Public Row As Long
Public NumRows As Long
Public Function connect(Optional server As String = "", Optional uid As String = "", Optional pwd As String = "", _
Optional dbname As String = "") As Boolean
Dim connStr As String
If (server = "") Then server = "DBServer"
If (uid = "") Then uid = "User1"
If (pwd = "") Then pwd = "1234"
If (dbname = "") Then dbname = "Database1"
If (uid = "") Then
connStr = "DRIVER={SQL Server};SERVER=" & server & ";Trusted_Connection=Yes;APP=Office 2007 App;DATABASE=" & dbname
Else
'connStr = "DRIVER={SQL Server};SERVER=" & server & ";UID=" & uid & ";PWD=" & pwd & ";APP=Office 2007 App;DATABASE=" & dbname
connStr = "Provider=SqlOleDb;Data Source=DBServer;Initial Catalog = Database1;UID=" & uid & ";PWD=" & pwd & ";Options=-1;"
End If
If (LinkID Is Nothing) Then
Set LinkID = New ADODB.Connection
On Error Resume Next
LinkID.Open connStr
On Error GoTo 0
If (LinkID.State = 0) Then
ErrorNo = Err.Number
ErrorTxt = Err.Description
End If
End If
connect = LinkID.State
End Function
Public Function query(Optional queryStr As String = "") As Boolean
If (queryStr = "") Then Exit Function
If Not (connect) Then Exit Function
If (QueryID Is Nothing) Then
Set QueryID = New ADODB.Recordset
ElseIf (QueryID.State) Then
free_result
End If
On Error Resume Next
QueryID.Open queryStr, LinkID, adOpenForwardOnly, adLockOptimistic, -1 ', adLockBatchOptimistic
On Error GoTo 0
Row = 0
If (QueryID.State = 0) Then
ErrorNo = Err.Number
ErrorTxt = Err.Description
End If
NumRows = count_records
query = QueryID.State
End Function
Public Sub free_result()
If Not (QueryID Is Nothing) Then
QueryID.Close
End If
End Sub
Public Function count_records() As Integer
count_records = 0
If Not (QueryID Is Nothing) Then
If (QueryID.State) Then
While (Not QueryID.EOF)
count_records = count_records + 1
QueryID.MoveNext
Wend
If (count_records) Then
QueryID.Requery
End If
End If
End If
End Function
Sub Test()
query "SELECT * FROM Table1 WHERE Empl = 'Tom'"
query "INSERT INTO Table1 (EMPL)Values ('Tod')"
query "DELETE FROM Table1 WHERE Empl = 'Tod'"
End Sub
RecordSet.Open is only used to open a cursor (select) not execute some DML. For this you can use Connection.Execute. The last can also be used to create a RecordSet.
See for example [http://msdn.microsoft.com/en-us/library/ms807027.aspx]