P2P Cloud DVR remote Access via a (remote) PC Using Guarding Vision PC Client Software

To support solution to this Thread:
http://www.excelfox.com/forum/showth...and-send-email


Test data supplied by Thainguyen for this Thread :
http://www.excelfox.com/forum/showth...and-send-email

Code:

---

Using Excel 2007 32 bit

Row\Col	A	B	C	D	E	F	G	H	I	J	K	N
1	Equipment PM
2	Machine EQ.ID	Manufacture	Model	Description	Serial Number	Weekly  Date of Service	Weekly  Next Service	Monthly Date of Service	Monthly Next  Service	Quarterly Date of Service	Quarterly Next Service	Softwear
3
4	1	JUKI	GKG GL	GL SCREEN PRINTER	A123	06.04.2018	13.04.2018	15.03.2018	12.04.2018	N/A	N/A
5	2	JUKI	KE-1070L	SMT Placement Machine	A124	11.04.2018	18.04.2018	28.03.2018	25.04.2018	N/A	N/A
6	9	ACE Production	KISS-101B	Selective  Wave Solder	A125	06.04.2018	13.04.2018	15.03.2018	12.04.2018	N/A	N/A
7	59	Heller	1826 MK5	Reflow Oven	A126	N/A	N/A	16.03.2018	13.04.2018	N/A	N/A
8	62	Exit Sign -- N/A -- Exit Lights	N/A	N/A	A127	N/A	N/A	N/A	N/A	N/A	N/A
9	69	South-Tek System	N2-Gen 35ST	Nitrogen Generator	A128	10.04.2018	17.04.2018	N/A	N/A	09.03.2018	06.04.2018
10	75	ACE Production	KISS-102	Selective  Wave Solder	A129	16.04.2018	23.04.2018	N/A	N/A	N/A	N/A
11	101	FKN system	N100 Nibbler	Dispensing	A130	N/A	N/A	N/A	N/A	04.04.2018	02.05.2018
12	109	Mycronic	MY200sx	SMT Machine	A131	N/A	N/A	N/A	N/A	N/A	N/A
13	112	X-TEK	XTV-160	X-Ray System	A132	N/A	N/A	N/A	N/A	N/A	N/A
14	113	MIRTEC	MV-6 OMNI	AOI	A133	N/A	N/A	N/A	N/A	N/A	N/A
15	116	JUKI	KE-2060RL	SMT Placement Machine	A134	N/A	N/A	N/A	N/A	N/A	N/A
16	127	ELGI	EG22-150	Air Compressor	A135	N/A	N/A	N/A	N/A	N/A	N/A
17	128	Juki	KE-2050	SMT	A136	N/A	N/A	N/A	N/A	N/A	N/A
18	137	Juki	K3	Screen printer	A137	06.04.2018	13.04.2018	N/A	N/A	N/A	N/A
19	141	Heller	1826 MK5	Reflow Oven	A138	N/A	N/A	N/A	N/A	N/A	N/A
20	142	NISSAN	MCU-112A331.V	Forklift	A139	N/A	N/A	N/A	N/A	15.02.2018	15.03.2018
21	142	NISSAN/yearly oil change and lube	MCU-112A331.V	Forklift	A140	N/A	N/A	N/A	N/A	N/A	N/A
22											28.01.1900
23

Worksheet: Equipment PM

---

Another view of last table

( for Thread: http://www.excelfox.com/forum/showth...and-send-email )

Using Excel 2007 32 bit

Equipment PM
Machine EQ.ID	Manufacture	Model	Description	Serial Number	Weekly Date of Service	Weekly Next Service	Monthly Date of Service	Monthly Next Service	Quarterly Date of Service	Quarterly Next Service
1	JUKI	GKG GL	GL SCREEN PRINTER	A123	06.04.2018	13.04.2018	15.03.2018	12.04.2018	N/A	N/A
2	JUKI	KE-1070L	SMT Placement Machine	A124	11.04.2018	18.04.2018	28.03.2018	25.04.2018	N/A	N/A
9	ACE Production	KISS-101B	Selective Wave Solder	A125	06.04.2018	13.04.2018	15.03.2018	12.04.2018	N/A	N/A
59	Heller	1826 MK5	Reflow Oven	A126	N/A	N/A	16.03.2018	13.04.2018	N/A	N/A
62	Exit Sign -- N/A -- Exit Lights	N/A	N/A	A127	N/A	N/A	N/A	N/A	N/A	N/A
69	South-Tek System	N2-Gen 35ST	Nitrogen Generator	A128	10.04.2018	17.04.2018	N/A	N/A	09.03.2018	06.04.2018
75	ACE Production	KISS-102	Selective Wave Solder	A129	16.04.2018	23.04.2018	N/A	N/A	N/A	N/A
101	FKN system	N100 Nibbler	Dispensing	A130	N/A	N/A	N/A	N/A	04.04.2018	02.05.2018
109	Mycronic	MY200sx	SMT Machine	A131	N/A	N/A	N/A	N/A	N/A	N/A
112	X-TEK	XTV-160	X-Ray System	A132	N/A	N/A	N/A	N/A	N/A	N/A
113	MIRTEC	MV-6 OMNI	AOI	A133	N/A	N/A	N/A	N/A	N/A	N/A
116	JUKI	KE-2060RL	SMT Placement Machine	A134	N/A	N/A	N/A	N/A	N/A	N/A
127	ELGI	EG22-150	Air Compressor	A135	N/A	N/A	N/A	N/A	N/A	N/A
128	Juki	KE-2050	SMT	A136	N/A	N/A	N/A	N/A	N/A	N/A
137	Juki	K3	Screen printer	A137	06.04.2018	13.04.2018	N/A	N/A	N/A	N/A
141	Heller	1826 MK5	Reflow Oven	A138	N/A	N/A	N/A	N/A	N/A	N/A
142	NISSAN	MCU-112A331.V	Forklift	A139	N/A	N/A	N/A	N/A	15.02.2018	15.03.2018
142	NISSAN/yearly oil change and lube	MCU-112A331.V	Forklift	A140	N/A	N/A	N/A	N/A	N/A	N/A
										28.01.1900

Worksheet: Equipment PM

Table from above again
Using Excel 2007 32 bit

Row\Col	F	G	H	I	J	K
1
2	Weekly Date of Service	Weekly Next Service	Monthly Date of Service	Monthly Next Service	Quarterly Date of Service	Quarterly Next Service
3
4	06.04.2018	13.04.2018	15.03.2018	12.04.2018	N/A	N/A
5	11.04.2018	18.04.2018	28.03.2018	25.04.2018	N/A	N/A
6	06.04.2018	13.04.2018	15.03.2018	12.04.2018	N/A	N/A
7	N/A	N/A	16.03.2018	13.04.2018	N/A	N/A
8	N/A	N/A	N/A	N/A	N/A	N/A
9	10.04.2018	17.04.2018	N/A	N/A	09.03.2018	06.04.2018
10	16.04.2018	23.04.2018	N/A	N/A	N/A	N/A
11	N/A	N/A	N/A	N/A	04.04.2018	02.05.2018
12	N/A	N/A	N/A	N/A	N/A	N/A
13	N/A	N/A	N/A	N/A	N/A	N/A
14	N/A	N/A	N/A	N/A	N/A	N/A
15	N/A	N/A	N/A	N/A	N/A	N/A
16	N/A	N/A	N/A	N/A	N/A	N/A
17	N/A	N/A	N/A	N/A	N/A	N/A
18	06.04.2018	13.04.2018	N/A	N/A	N/A	N/A
19	N/A	N/A	N/A	N/A	N/A	N/A
20	N/A	N/A	N/A	N/A	15.02.2018	15.03.2018
21	N/A	N/A	N/A	N/A	N/A	N/A
22						28.01.1900

Worksheet: Equipment PM

Code for this Thread:
http://www.excelfox.com/forum/showth...and-send-email

Code:

---

Option Explicit
Private Sub Workbook_Open()
Rem 1 Worksheets Info.
Dim Ws As Worksheet: Set Ws = ThisWorkbook.Worksheets("Equipment PM")
Dim Lr As Long: Let Lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row
Rem 2 data range
Dim arrIn() As Variant: Let arrIn() = Ws.Range("A1:K" & Lr & "").Value2
Rem 3 Todays date as Double(Long) number
Dim TdyDbl As Long: Let TdyDbl = CLng(Now()) ' like 43233 for 13 May 2018
 Let TdyDbl = CLng(DateSerial(2018, 3, 15)) - 3 ' To test only #####
Rem 4 Rows for due date for next service for weekly(G), Monthly(I), and Quarterly(K). Code to pick up the date from these columns and automatic send email notification 3 days before the due date.
'4a) determine rows as string or those row numbers
Dim Rw As Long
    For Rw = 4 To Lr Step 1
        If arrIn(Rw, 7) = TdyDbl + 3 Or arrIn(Rw, 9) = TdyDbl + 3 Or arrIn(Rw, 11) = TdyDbl + 3 Then
    Dim strRws As String 'String of rows for criteria met in  G  Or  I  Or  K
    Let strRws = strRws & " " & Rw
        Else ' No "3 days before due service date" criteria met for this row
        End If
    Next Rw
    If strRws = "" Then Exit Sub ' case no criteria met for the day this workbook was opened.
 Let strRws = VBA.Strings.Mid$(strRws, 2) ' take off first space
'4b) Array of rows
Dim arrRws() As String: Let arrRws() = VBA.Strings.Split(strRws, " ", -1, vbBinaryCompare)
Rem 5 HTML Table of required output '
Dim ProTble As String
'5a) Table start
Let ProTble = _
"<table width=520>" & vbCrLf & _
"<col width=30>" & vbCrLf & _
"<col width=150>" & vbCrLf & _
"<col width=150>" & vbCrLf & _
"<col width=150>" & vbCrLf & _
"<col width=40>" & vbCrLf & vbCrLf
'5b) data rows
Dim iCnt As Long, jCntStear As Variant, jCnt As Long ' data "columns" ,    "rows"
    For Each jCntStear In arrRws() ' To Loop for all rows meeting criteria
    Let jCnt = jCnt + 1  ' Rows count for table to send
    Dim LisRoe As String
    Let LisRoe = LisRoe & "<tr height=16>" & vbCrLf
        For iCnt = 1 To 5
        Let LisRoe = LisRoe & "<td>" & arrIn(arrRws(jCnt - 1), iCnt) & "</td>" & vbCrLf ' -1 is because Split Function returns array of string types in 1 Dimensional array starting at indice 0, so our jCnt is one too big
        Next iCnt
    Let LisRoe = LisRoe & "</tr>" & vbCrLf & vbCrLf
    Let ProTble = ProTble & LisRoe
    Let LisRoe = ""
    Next jCntStear
 Let ProTble = ProTble & "</table>" ' table end
 Debug.Print ProTble
Rem 6 EMail send 'For info see:  http://www.excelfox.com/forum/showth...once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
    With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
    Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
    .Configuration(LCD_CW & "smtpusessl") = True '
    .Configuration(LCD_CW & "smtpauthenticate") = 1  '
    '  ' Sever info
    .Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"
    '  The mechanism to use to send messages.
    .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
    .Configuration(LCD_CW & "smtpserverport") = 25 ' 465 or 25 for t-online.de 'or 587 'or 25
    '

    .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
    .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
    ' Optional - How long to try
    .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
    ' Intraction protocol is Set/ Updated
    .Configuration.Fields.Update '
    'End With ' ----------------------      my Created  LCDCW Library
    'With ' --- ' Data to be sent------    my Created  LCDCW Library
    Dim strHTML As String: Let strHTML = ProTble 'ProTble(rngArr()) ' Let strHTML = RangetoHTML(rng)
    '        Dim Highway1 As Long: Let Highway1 = FreeFile(0) '
    '          Open ThisWorkbook.Path & "" & "jawaharse.txt" For Output As #Highway1 '
    '          Print #Highway1, strHTML
    '          Close #Highway1
    .To = "Doc.AElstein@t-online.de" '
    .cc = ""
    .BCC = ""
    .from = """Equipment- Maint Records.xlsm"" <YourEMailAddresseOrAnyCrap>"
    .Subject = Ws.Range("A1").Value
    .HTMLBody = strHTML
    '        .AddAttachment ThisWorkbook.Path & "\jawaharse.txt"
    .Send ' Do it
    End With ' CreateObject("CDO.Message") -----my Created  LCDCW Library
End Sub

---

To support this Thread
http://www.excelfox.com/forum/showth...0679#post10679

Re post code in Code tags, Like ....

Please use CODE TAGS if you are writing codes in your post.

To use code tags,
either
select your entire code and press the code tag button # in the editor below,
or
simply type your code as below

[Code]Your Code Here[/Code]

[Code]
Your Code Here
[/Code]




[Code]
Private Sub cmdNot_Click()

Dim OutApp As Object
Dim OutMail As Object

…………………….

……………..

End Sub
[/Code]




BBCodeCodeTags.JPG : https://imgur.com/4HunNcs
Attachment 2060

_.__________________

If you post using Code tags, then it will come out in the final post in a Code Window, like this:

Code:

---

Private Sub cmdNot_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim fileName As String
Dim mSubject As String
Dim signature As String
Dim fname As String
Dim mBody As String
Dim rng As Range
Dim rng1 As Range
Dim ws As Worksheet
Dim mailTo As String
 Set ws = Sheets("MRO")
 fname = ws.Range("B4")
 mSubject = "MRO " & " For " & Range("C6").Value
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)
'mBody = "2-SO\Material Request Form .xlsm"

Dim Path As String

 mBody = "<font size=""3"" face=""Calibri"">" & _
"Dear Team,<br><br>" & _
"Please open the file from below link and put your signature on the respective cell after you completed your task.<br><B>" & _
fileName & ".xlsm" & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & Path & fileName & ".xlsm" & _
""">Files are saved here</A>" & "-->" & Range("C6").Value & _
"<br><br>Best Regards," & _
"<br><br></font>"

    With OutMail
    .display
    End With
 signature = OutMail.body
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With

    With OutMail
    '.To = "email"
    .To = ""
    .CC = ""
    .BCC = ""
    .Subject = mSubject
    '.body = "Dear Team," & vbCrLf & vbCrLf & "Please open the file from below link and put your signature on the respective cell and save the sheet"
    '.htmlbody = RangetoHTML(rng)
    .htmlbody = mBody
    '.Attachments.Add fileName
    .display
    End With
 'ws.PageSetup.RightHeader = "&""Calibri,italic""&11& " & ws.Range("A1")
 ActiveWorkbook.Close False
 ActiveWorkbook.Close
 On Error GoTo 0

 Set OutMail = Nothing
 Set OutApp = Nothing

    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With

---

Code in code tags from here:
http://www.excelfox.com/forum/showth...0699#post10699

Code:

---

Dim OutApp As Object
Dim OutMail As Object
Dim fileName As String
Dim mSubject As String
Dim signature As String
Dim fname As String
Dim mBody As String
Dim rng As Range
Dim rng1 As Range
Dim ws As Worksheet
Dim mailTo As String
 fname = ws.Range("A1")
 mSubject = "Equipment" & " For " & Range("A1").Value
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)
 'mBody = "Z:\2\Form\\Manufacturing Order.xlsm"

Dim Path As String
 ws.Protect ("Equipment")
 Path = "\\Equipment- Maint RecordsThai1.xlsm"
 mBody = "<font size=""3"" face=""Calibri"">" & _
  "Dear Team,<br><br>" & _
  "Please open the file from below link and change the date on the respective cell after you completed your task.<br><B>" & _
  fileName & ".xlsm" & "</B> is created.<br>" & _
  "Click on this link to open the file : " & _
  "<A HREF=""file://" & Path & fileName & ".xlsm" & _
  """>Files are saved here</A>" & "-->" & Range("A1").Value & _
  "<br><br>Best Regards," & _
  "<br><br></font>"

    With OutMail
    .display
    End With
 signature = OutMail.body
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With

---

Code:

---

Private Sub cmdNot_Click()
    If Application.UserName = "Thai Nguyen" Then
    Dim ws As Worksheet: Set ws = Sheets("Name")
    Dim rng As Range, rng1 As Range
    Dim fileName As String, fname As String
    Let fname = ws.Range("B4")
    Let mSubject = "Name"
    Dim OutApp As Object, OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Dim Subject As String, signature As String, mBody As String, mailTo As String
        'mBody = "copy you link path in here"
    Let mBody = "<font size=""3"" face=""Calibri"">" & _
    "Hi Team,<br><br>" & _
    "Please open the file from below link and put your signature on the respective cell after you completed your task.<br><B>" & _
    ActiveWorkbook.Name & "</B> is created.<br>" & _
    "Click on this link to open the file : " & _
    "<A HREF=""file://" & ActiveWorkbook.FullName & """>Link to the file</A>" & _
    "<br><br>Regards," & _
    "<br><br>Thai Nguyen</font>    "
    OutMail.display
    Let signature = OutMail.body
        With Application
        .EnableEvents = False
        .ScreenUpdating = False
        End With
        With OutMail
        '.To = "email"
            If ws.Range("EU16") = True Then
            Let mailTo = mailTo + "Thai Nguyen;"
            Else
            End If
            If ws.Range("EU17") = True Then
            mailTo = mailTo + "email"
            End If
            If ws.Range("EU18") = True Then
            Let mailTo = mailTo + "email"
            End If
            If ws.Range("EU19") = True Then
            Let mailTo = mailTo + "email"
            End If
        .To = mailTo
        .CC = "Thai Nguyen"
        .BCC = ""
        .Subject = mSubject
        '.body = "Hi Team," & vbCrLf & vbCrLf & "Please open the file from below link and put your signature on the respective cell and save the sheet"
        '.htmlbody = RangetoHTML(rng)
        .htmlbody = mBody
        '.Attachments.Add fileName
        .display
        End With
    'ws.PageSetup.RightHeader = "&""Calibri,italic""&11& " & ws.Range("A1")
    ws.Protect ("Name")
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    On Error GoTo 0
   
    Set OutMail = Nothing
    Set OutApp = Nothing
        With Application
        .ScreenUpdating = True
        .EnableEvents = True
        End With
    Else
    MsgBox "You are not authorised to send BOM form, please check with BOM owner"
    End If
End Sub

---

Share account for testing file access from a hyperlink in a received EMail

In support of a possible solution to this post in this Thread:
http://www.excelfox.com/forum/showth...0724#post10724

It is required to have a simple hyperlink to an Excel File appear in the received Email sent to members of a team.
I am not sure currently how to get a link directly to the File.

An second alternative involves storing the file at a File sharing site and using the link to the file as the URL part of a hyperlink.

This post discusses the setting up of such an account to allow storing of, and sharing via a supplied link to, the file.

As an example of a file sharing site we consider the free version of box.net
Some googling my be needed to finally get at the free version which may go under the name of “free” , “Individual rate”, “Personal free”
Currently you need to find your way to the free 10GB offer. This is currently at this link:
https://account.box.com/signup/n/personal#fbms6
Free10GB box net account register.JPG : https://imgur.com/NB3GThi
Note , by registering, you can choose a language to suit you.
Free10GB Select language .JPG : : https://imgur.com/aNzW1kq
( You can change the language to a different one after registering also
Free10GB Change language .JPG : https://imgur.com/IosqbAI )


For this registering , I use the created gmail account used for experiments in the current thread which this post supports, excellearning12@gmail.com ( excelfox Thread : http://www.excelfox.com/forum/showth...and-send-email )

The password I pass on privately to those needing
Free10GB box net account register 2.JPG : https://imgur.com/Y2pLogO
Free10GB box net account register 3.JPG : https://imgur.com/QhCR8fP
Free10GB box net account register Verify Email 4.JPG : https://imgur.com/ffG7erw

Various steps are then gone through, they may be slightly different to the following:

At some point you should you should see the possibility to upload a file, following steps similar to these:
Free10GB box net 5 .JPG : https://imgur.com/lNWvQwF
To upload a file and get a URL link to use in a hyperlink to it:
Upload Files:
Free10GB box net 6 .JPG : https://imgur.com/rTU1Xbk
Select a file:
Free10GB box net 7 .JPG : https://imgur.com/wKKlqoO
Select share to obtain a URL link to the file :
Free10GB box net 8 .JPG : https://imgur.com/R3VbyhR
Copy link to be used in Hyperlink :
Free10GB box net 9 .JPG : https://imgur.com/8yaYwaK

Testing codes in support of this Thread
http://www.excelfox.com/forum/showth...0727#post10727







Codes for Alf and sandy666

Code:

---

Option Explicit
Sub SendfromExcelVBAExpgmail()
Rem 6 EMail send 'For info see:  http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
    '6a(i)
    With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
    Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
    .Configuration(LCD_CW & "smtpusessl") = True '
    .Configuration(LCD_CW & "smtpauthenticate") = 1  '
    '  ' Sever info
    .Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "smtp.office365.com" ' "smtp.live.com" ' "smtp-mail.outlook.com" ' "smtp.live.com" ' "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"
    '  The mechanism to use to send messages.
    .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
    .Configuration(LCD_CW & "smtpserverport") = 465 ' 465 or 25 for gmail '587 ' 25  ' 465 or 25 for t-online.de 'or 587 'or 25
    '
    .Configuration(LCD_CW & "sendusername") = "ExcelVBAExp@gmail.com" '
    .Configuration(LCD_CW & "sendpassword") = "xxxxxxxxxxxxxx"      '                                  '
'    .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
'    .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
    ' Optional - How long to try
    .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
    ' Intraction protocol is Set/ Updated
    .Configuration.Fields.Update '
    'End With 6a(i)' ----------------------        my Created  LCDCW Library
    '6a(ii) With  ' -- ' Data to be sent---      my Created  LCDCW Library
    Dim strHTML As String: Let strHTML = "<font size=""3"" face=""Calibri"">" & _
    "This is sent from EMail account:" & _
    "<br>Username: ""ExcelVBAExp@gmail.com""" & _
    "<br>Password: ""xxxxxxxxxxxxxxxxxxxxxx""" & _
    "<br><br>" & _
    "<br>Please click on the 5 links below and tell me what happens, thanks!" & _
    "<br>1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
    "<br>2 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>3 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>4 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>" & _
    "<br>5 <A HREF=""file:///" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>"
    .To "xxxxxxxxxxxxxx"
    .CC "xxxxxxxxxxxxxa"

    .BCC = ""
    .from = """ExcelVBAExp@gmail.com"" <ExcelVBAExp@gmail.com>"
    .Subject = "Sent from EMail address: ExcelVBAExp@gmail.com"
    .htmlbody = strHTML

    .Send ' Do it
    End With ' 6a(ii) CreateObject("CDO.Message") ---my Created  LCDCW Library
End Sub

Sub SendfromFahrradprinzessinunterwegsgmail()
Rem 6 EMail send 'For info see:  http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
    '6a(i)
    With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
    Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
    .Configuration(LCD_CW & "smtpusessl") = True '
    .Configuration(LCD_CW & "smtpauthenticate") = 1  '
    '  ' Sever info
    .Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "smtp.office365.com" ' "smtp.live.com" ' "smtp-mail.outlook.com" ' "smtp.live.com" ' "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"
    '  The mechanism to use to send messages.
    .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
    .Configuration(LCD_CW & "smtpserverport") = 465 ' 465 or 25 for gmail '587 ' 25  ' 465 or 25 for t-online.de 'or 587 'or 25
    '
    .Configuration(LCD_CW & "sendusername") = "Fahrradprinzessinunterwegs@gmail.com" '
    .Configuration(LCD_CW & "sendpassword") = "xxxxxxxxxxxxx"      '                                  '
'    .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
'    .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
    ' Optional - How long to try
    .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
    ' Intraction protocol is Set/ Updated
    .Configuration.Fields.Update '
    'End With 6a(i)' ----------------------        my Created  LCDCW Library
    '6a(ii) With  ' -- ' Data to be sent---      my Created  LCDCW Library
    Dim strHTML As String: Let strHTML = "<font size=""3"" face=""Calibri"">" & _
    "This is sent from EMail account:" & _
    "<br>Username: ""Fahrradprinzessinunterwegs@gmail.com""" & _
    "<br>Password: ""xxxxxxxxxxxxxxxxxxx""" & _
    "<br><br>" & _
    "<br>Please click on the 5 links below and tell me what happens, thanks!" & _
    "<br>1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
    "<br>2 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>3 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>4 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>" & _
    "<br>5 <A HREF=""file:///" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>"
    .To "xxxxxxxxxxxxxxxxxxxx"
    .CC "xxxxxxxxxxxxxxxxxxx"
    .BCC = ""
    .from = """Fahrradprinzessinunterwegs@gmail.com"" <Fahrradprinzessinunterwegs@gmail.com>"
    .Subject = "Sent from EMail address: Fahrradprinzessinunterwegs@gmail.com"
    .htmlbody = strHTML

    .Send ' Do it
    End With ' 6a(ii) CreateObject("CDO.Message") ---my Created  LCDCW Library
End Sub



Sub SendfromDocAlnsteinGermanTelekom()
Rem 6 EMail send 'For info see:  http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
    '6a(i)
    With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
    Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
    .Configuration(LCD_CW & "smtpusessl") = True '
    .Configuration(LCD_CW & "smtpauthenticate") = 1  '
    '  ' Sever info
    .Configuration(LCD_CW & "smtpserver") = "securesmtp.t-online.de" ' "smtp.gmail.com" ' "smtp.office365.com" ' "smtp.live.com" ' "smtp-mail.outlook.com" ' "smtp.live.com" ' "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"
    '  The mechanism to use to send messages.
    .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
    .Configuration(LCD_CW & "smtpserverport") = 465 ' 465 or 25 for gmail '587 ' 25  ' 465 or 25 for t-online.de 'or 587 'or 25
    '
    .Configuration(LCD_CW & "sendusername") = "Doc.Alnstein@t-online.de" '
    .Configuration(LCD_CW & "sendpassword") = "xxxxxxxxx"      '                                  '
'    .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
'    .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
    ' Optional - How long to try
    .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
    ' Intraction protocol is Set/ Updated
    .Configuration.Fields.Update '
    'End With 6a(i)' ----------------------        my Created  LCDCW Library
    '6a(ii) With  ' -- ' Data to be sent---      my Created  LCDCW Library
    Dim strHTML As String: Let strHTML = "<font size=""3"" face=""Calibri"">" & _
    "This is sent from EMail account:" & _
    "<br>Username: ""Doc.Alnstein@t-online.de""" & _
    "<br>Password: ""xxxxxxxxxxx""" & _
    "<br><br>" & _
    "<br>Please click on the 5 links below and tell me what happens, thanks!" & _
    "<br>1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
    "<br>2 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>3 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>4 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>" & _
    "<br>5 <A HREF=""file:///" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>"
    .To "xxxxxxxxxxxxxxxxxxxxxxxx"
    .CC "xxxxxxxxxxxxxxxxxxxxxxxxx"

    .BCC = ""
    .from = """Doc.Alnstein@t-online.de"" <Doc.Alnstein@t-online.de>"
    .Subject = "Sent from EMail address: Doc.Alnstein@t-online.de"
    .htmlbody = strHTML

    .Send ' Do it
    End With ' 6a(ii) CreateObject("CDO.Message") ---my Created  LCDCW Library
End Sub

---

Instructions:
Three files are attached. Please download them and store them all somewhere on your computer. They can be stored anywhere, but important is that they are all stored in the same Folder :
All 3 files stored in same place.JPG : https://imgur.com/rFu0TML

Please open only one file “Test File xxxx to send EMail containing Hyperlinks to Files.xlsm”
Enable macros.

There are three codes in file “Test File xxxx to send EMail containing Hyperlinks to Files.xlsm”.
The codes are very similar, differing only in the Email account used as the .Sender:
Sub SendfromDocAlnsteinGermanTelekom()
Sub SendfromFahrradprinzessinunterwegsgmail()
Sub SendfromExcelVBAExpgmail()

Please try to run those codes.
Each code should send you an Email which on arrival will look something similar to this:
Typical received EMail.JPG : https://imgur.com/4oNXNtW

Please click on the 5 Hyperlinks and tell me what happens.


My final goal is to get a Hyperlink which when clicked opens an Excel or Word File.
I have tested the codes sending to my gmail and German Telekom Email accounts.
But so far, only link 1 works. But link 1 does not open a file: It simply sends you to a file sharing site. So link 1 is a temporary solution for me.









Code for Thai in next post....

Code for Thai .

Code:

---

Option Explicit
Sub Sendfromexcellearninggmail()
Rem 6 EMail send 'For info see:  http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
    '6a(i)
    With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
    Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
    .Configuration(LCD_CW & "smtpusessl") = True '
    .Configuration(LCD_CW & "smtpauthenticate") = 1  '
    '  ' Sever info
    .Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "smtp.office365.com" ' "smtp.live.com" ' "smtp-mail.outlook.com" ' "smtp.live.com" ' "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"
    '  The mechanism to use to send messages.
    .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
    .Configuration(LCD_CW & "smtpserverport") = 465 ' 465 or 25 for gmail '587 ' 25  ' 465 or 25 for t-online.de 'or 587 'or 25
    '
    .Configuration(LCD_CW & "sendusername") = "excellearning12@gmail.com" '
    .Configuration(LCD_CW & "sendpassword") = "xxxxxxxxxxxxx"      '                                  '
'    .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
'    .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
    ' Optional - How long to try
    .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
    ' Intraction protocol is Set/ Updated
    .Configuration.Fields.Update '
    'End With 6a(i)' ----------------------        my Created  LCDCW Library
    '6a(ii) With  ' -- ' Data to be sent---      my Created  LCDCW Library
    Dim strHTML As String: Let strHTML = "<font size=""3"" face=""Calibri"">" & _
    "This is sent from EMail account:" & _
    "<br>Username: ""excellearning12@gmail.com""" & _
    "<br>Password: ""xxxxxxxxxxxxx""" & _
    "<br><br>" & _
    "<br>Please click on the 5 links below and tell me what happens, thanks!" & _
    "<br>1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
    "<br>2 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>3 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
    "<br>4 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>" & _
    "<br>5 <A HREF=""file:///" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>"
    .To = "THai xxxxxxxxx"
    '.CC = "xxxxxxxxxxxxx"
    .BCC = ""
    .from = """excellearning12@gmail.com"" <excellearning12@gmail.com>"
    .Subject = "Sent from EMail address: excellearning12@gmail.com"
    .htmlbody = strHTML

    .Send ' Do it
    End With ' 6a(ii) CreateObject("CDO.Message") ---my Created  LCDCW Library
End Sub

---

Testing files( sent privately ) :
I have also posted 3 files to you using our share g mail account , ExcelVBAExp@gmail.com
Please can you also try out the test…

Please do the following.

_1) Download all three files , and important: All must be stored in the same Folder.
( the three files are:
Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received Email.htm
Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls
Test File Thai to send EMail containing Hyperlinks to Files.xlsm )

_2) Open only file Test File Thai to send EMail containing Hyperlinks to Files.xlsm
Run code Sub Sendfromexcellearninggmail()

You should receive an Email similar to these:
Alan 5 Links in German Telekom.JPG : https://imgur.com/LeASbhf
Attachment 2079
Alan 5 Links in gmail.JPG : https://imgur.com/0sdyZEj
Attachment 2080

_3) Please click on the links.

_4) Please reply and tell me what happens when you click each link

Thanks
Alan

First test code for solution to this thread:
http://www.excelfox.com/forum/showth...le-or-two-tabs

( Run code Sub TestieCalls() )

Code:

---

Option Explicit
Sub TestieCalls()
 Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub
Sub Testie(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
 Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
 Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
    If lr1_1 > Lr1_2 Then
    Let Lr1 = lr1_1
    Else
    Let Lr1 = Lr1_2
    End If
 Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
 Let arrSht1() = Ws1.Range("A1:B" & Lr1 & "").Value
 Let arrSht2() = Ws2.Range("A1:B" & lr2 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String
'2a size arrays to that of sheet 2 data
 ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
 ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
'2b fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1
    Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
    Next Cnt
Rem 3 main loop  ' == Start main loop ==========
    For Cnt = 1 To UBound(arrSht2(), 1) - 1 Step 1 ' Counting at each row
    Dim DifCnt As Long 'Count of different cells
        ' Condition check
        If (arrSht2(Cnt, 1) <> arrSht1b(Cnt, 1) Or arrSht2(Cnt, 2) <> arrSht1b(Cnt, 2)) And (arrSht2(Cnt + 1, 1) = arrSht1b(Cnt + 1, 1) And arrSht2(Cnt + 1, 2) = arrSht1b(Cnt + 1, 2)) Then  ' condition for changed row but next row is as previous : row had data changed, but a row was not inserted
        Let arrSht1b(Cnt, 1) = arrSht2(Cnt, 1): arrSht1b(Cnt, 2) = arrSht2(Cnt, 2) 'change any changed cell
            If arrSht1b(Cnt, 1) <> arrSht1(Cnt, 1) Then
            Let arrOut(Cnt, 1) = arrSht1b(Cnt, 1) & "  <>  " & arrSht1(Cnt, 1)
            Let DifCnt = DifCnt + 1
            Else: End If
            If arrSht1b(Cnt, 2) <> arrSht1(Cnt, 2) Then
            Let arrOut(Cnt, 2) = arrSht1b(Cnt, 2) & "  <>  " & arrSht1(Cnt, 2)
            Let DifCnt = DifCnt + 1
            Else: End If
        ' Condition check
        ElseIf ((arrSht2(Cnt, 1) <> arrSht1b(Cnt, 1) Or arrSht2(Cnt, 2) <> arrSht1b(Cnt, 2)) And (arrSht2(Cnt + 1, 1) <> arrSht1b(Cnt + 1, 1) Or arrSht2(Cnt + 1, 2) <> arrSht1b(Cnt + 1, 2))) Then  ' main condition suggesting added new row
        Dim AdedRows As Long: Let AdedRows = AdedRows + 1
        '3b we need to shift all data down to allow space for new row in arrSht2()
        Dim CntIn As Long
            For CntIn = (UBound(arrSht2(), 1) - 1) To Cnt Step -1 'loop for all but last from this row
            Let arrSht1b(CntIn + 1, 1) = arrSht1b(CntIn, 1): arrSht1b(CntIn + 1, 2) = arrSht1b(CntIn, 2) ' This effectively pulls up each row by one
            Next CntIn
        '3c add the new data to the modified array, Let arrSht1b()
        Let arrSht1b(Cnt, 1) = arrSht2(Cnt, 1): arrSht1b(Cnt, 2) = arrSht2(Cnt, 2)
            If arrSht1b(Cnt, 1) = "" Then arrSht1b(Cnt, 1) = "          " ' Just to make final output more neat
            If arrSht1b(Cnt, 2) = "" Then arrSht1b(Cnt, 2) = "          "
        '3d add info to the output array
            If Cnt > UBound(arrSht1(), 1) Then ' case of new lines
            Let arrOut(Cnt, 1) = "An new extra line contains  " & arrSht1b(Cnt, 1): arrOut(Cnt, 2) = "An new extra line contains  " & arrSht1b(Cnt, 2)
           
            Else
              If arrSht1b(Cnt, 1) <> arrSht1(Cnt, 1) Then
                Let arrOut(Cnt, 1) = arrSht1b(Cnt, 1) & "  <>  " & arrSht1(Cnt, 1)
                Let DifCnt = DifCnt + 1
              Else: End If
              If arrSht1b(Cnt, 2) <> arrSht1(Cnt, 2) Then
                Let arrOut(Cnt, 2) = arrSht1b(Cnt, 2) & "  <>  " & arrSht1(Cnt, 2)
                Let DifCnt = DifCnt + 1
              Else: End If
            End If
        '
        Let Cnt = Cnt + 1 ' we need to skip the next row as that was just effectively added so we are done with it
        Else ' row has not been added here
       
        End If
    Next Cnt ' ========= End main loop ==========
Rem 4 last row may be new
    If arrSht2(lr2, 1) <> arrSht1(Lr1, 1) Or arrSht2(lr2, 2) <> arrSht1(Lr1, 2) Then ' either cell in last row is different
        If arrSht2(lr2, 1) <> arrSht1(Lr1, 1) Then
        Let arrOut(lr2, 1) = arrSht2(lr2, 1) & "  on last row is new"
        Let DifCnt = DifCnt + 1
        Else: End If
        If arrSht2(lr2, 2) <> arrSht1(Lr1, 2) Then
        Let arrOut(lr2, 2) = arrSht2(lr2, 2) & "  on last row is new"
        Let DifCnt = DifCnt + 1
        Else: End If
    Else 'last row on sheet2 is as on sheet1
    End If
Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3 
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Tabelle3")
 Ws3.Cells.ClearContents
 Let Ws3.Range("A1:B1").Value = "Sheet1": Ws3.Range("C1:D1").Value = "Test Output": Ws3.Range("E1:F1").Value = "Sheet2"
 Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
 Let Ws3.Range("C2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
 Let Ws3.Range("E2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
 Ws3.Columns.AutoFit
Rem 6 MsgBoox output
 MsgBox Prompt:="inserted lines is  " & AdedRows & vbCrLf & "Changed cells is  " & DifCnt
End Sub

---