the code below is creating an email, whilst searching through folders and attaching the relevant docs.
I have coded it to check whether the user has sent the email or closed it. I have put it so an input box gets displayed when the user closes the email. What i would like to happen is when the email gets closed, is the InputBox is set to focus, and after a reason why the email was sent have been entered then go back to the email to click on don't save draft.
Or even have the input box display after the email has been closed, after the save without changed dialog box.
Userform Code:
Dim OutApp As Object
Dim itmevt As New CMailItemEvents
Private Sub btnEMSent_Click()
Dim i, j, lastG, lastD As Long
Dim OutMail As Object
Dim sFName As String, colFiles As New Collection
Dim myDir As String, ChDir As String, attName As New Collection, attName2 As String
Dim dte As String
Dim greet As String, cntName As String, SigString As String, Signature As String
lastG = Sheets("File Locations").Cells(Rows.Count, "B").End(xlUp).Row
SigString = "H:\AppData\Roaming\Microsoft\Signatures\"
If Dir(SigString, vbDirectory) <> vbNullString Then
SigString = SigString & Dir$(SigString & "*.htm")
Else:
SigString = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(SigString).OpenAsTextStream(1, -2).readall
If Me.cmbMonth.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Payment Month Required!"
Me.cmbMonth.SetFocus
Exit Sub
ElseIf Me.txtbxYear.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Payment Year Required!"
Me.txtbxYear.SetFocus
Exit Sub
ElseIf Me.cmbSubbie.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Sub-Contractor Required!"
Me.cmbSubbie.SetFocus
Exit Sub
End If
For i = 1 To lastG
lookupVal = Sheets("File Locations").Cells(i, "B") ' value to find
If Dir(lookupVal, vbDirectory) = "" Then
Else
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set itmevt.itm = OutMail
dte = Me.cmbMonth.Value & " " & Me.txtbxYear.Text
myDir = lookupVal 'Set Dir to search
ChDir = (myDir & "\" & Me.cmbSubbie.Value & "\Remittance\") 'Change to that dir
sFName = Dir(ChDir & "*" & dte & "*") 'Set Search spec
While InStr(sFName, dte)
colFiles.Add (ChDir & sFName)
attName.Add (sFName)
sFName = Dir
Wend
End If
Next i
On Error Resume Next
With OutMail
If Me.txtbxSubNAME.Value <> "" Then
cntName = " " & Me.txtbxSubNAME.Value & ","
Else
cntName = ","
End If
If Time < TimeValue("12:00:00") Then
greet = "Good Morning" & cntName
Else
greet = "Good Afternoon" & cntName
End If
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
.Attachments.Add colFiles(i)
attName2 = attName(i) & "<br>" & attName2
Next i
End If
.To = Me.txtbxSubEMAIL.Value
.CC = ""
.BCC = ""
.Subject = Me.cmbMonth.Value & "'s Remittances"
.BodyFormat = olFormatHTML
.HTMLbody = "<HTML><BODY></BODY></HTML>" & .HTMLbody & Signature
.Display True
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
In the class module CMailItemEvents:
Option Explicit
Public WithEvents itm As Outlook.MailItem
Private Declare PtrSafe Function MessageBox _
Lib "User64" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
Private Sub itm_Close(Cancel As Boolean)
Dim blnSent As Boolean
Dim lastG As Long
Dim myValue As Variant
lastG = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Row + 1
On Error Resume Next
blnSent = itm.Sent
If Err.Number = 0 Then
myValue = inputBox("Why was " & usrFrmEMAIL.cmbSubbie & " Remittance E-Mail not sent?", "Remittance Error")
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
AppActivate (myValue.ActiveExplorer.CurrentItem)
Sheets("Report").Range("D" & lastG).Value = myValue
Exit Sub
Else
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
End If
End Sub
sorry for taking so long to get back, i've been away on holiday.
I managed to figure out how to get this to work.
Class Module:
Option Explicit
Private Declare Function GetWindowThreadProcessId Lib _
"user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function AttachThreadInput Lib "user32" _
(ByVal idAttach As Long, ByVal idAttachTo As Long, _
ByVal fAttach As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function IsIconic Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName _
As Long, ByVal lpWindowName As String) As Long
Const SW_SHOW = 5
Const SW_RESTORE = 9
Public WithEvents itm As Outlook.MailItem
Function ForceForegroundWindow(ByVal hWnd As Long) As Boolean
Dim ThreadID1 As Long
Dim ThreadID2 As Long
Dim nRet As Long
If hWnd = GetForegroundWindow Then
ForceForegroundWindow = True
Else
ThreadID1 = GetWindowThreadProcessId( _
GetForegroundWindow, ByVal 0&)
ThreadID2 = GetWindowThreadProcessId(hWnd, ByVal 0&)
If ThreadID1 <> ThreadID2 Then
AttachThreadInput ThreadID1, ThreadID2, True
nRet = SetForegroundWindow(hWnd)
AttachThreadInput ThreadID1, ThreadID2, False
Else
nRet = SetForegroundWindow(hWnd)
End If
If IsIconic(hWnd) Then
ShowWindow hWnd, SW_RESTORE
Else
ShowWindow hWnd, SW_SHOW
End If
ForceForegroundWindow = CBool(nRet)
End If
End Function
Private Sub itm_Close(Cancel As Boolean)
Dim blnSent As Boolean
Dim lastG As Long, currentrow As Integer
Dim myValue As String
Dim bOK As Boolean
Dim idx As Long
idx = usrFrmEMAIL.cmbSubbie.ListIndex
lastG = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Row + 1
On Error Resume Next
blnSent = itm.Sent
If Err.Number = 0 Then
itm.Close olDiscard
ForceForegroundWindow FindWindowA(0, Application.Caption)
Do
myValue = inputBox("Why was " & usrFrmEMAIL.cmbSubbie & "'s Remittance E-Mail not sent?", "Remittance Error")
If StrPtr(myValue) = 0 Then
bOK = False
MsgBox "You cannot just press Cancel!" & vbLf & vbLf & "A reason is needed for not sending the email.", vbCritical
ElseIf myValue = "" Then
bOK = False
MsgBox "You didn't enter anything, but pressed OK" & vbLf & vbLf & "A reason is needed for not sending the email.", vbExclamation
ElseIf Len(Application.WorksheetFunction.Substitute(myValue, " ", "")) = 0 Then
bOK = False
MsgBox "You only entered spaces!" & vbLf & vbLf & "A reason is needed for not sending the email.", vbExclamation
Else
bOK = True
Exit Do
End If
Loop Until bOK = True
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
Sheets("Report").Range("D" & lastG).Value = myValue
If idx <> usrFrmEMAIL.cmbSubbie.ListCount - 1 Then
usrFrmEMAIL.cmbSubbie.ListIndex = idx + 1
Else
usrFrmEMAIL.cmbSubbie.ListIndex = 0
End If
Else
For currentrow = 6 To lastG
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
Sheets("Report").Range("D" & lastG).Value = "Sent"
Next
If idx <> usrFrmEMAIL.cmbSubbie.ListCount - 1 Then
usrFrmEMAIL.cmbSubbie.ListIndex = idx + 1
Else
usrFrmEMAIL.cmbSubbie.ListIndex = 0
End If
End If
End Sub
UserForm Code:
Dim OutApp As Object
Dim itmevt As New CMailItemEvents
Private Sub btnCreateEmail_Click()
Dim i, j, lastG, lastD As Long
Dim OutMail As Object
Dim sFName As String, colFiles As New Collection
Dim myDir As String, ChDir As String, attName As New Collection, attName2 As String
Dim dte As String
Dim greet As String, cntName As String, SigString As String, Signature As String
lastG = Sheets("File Locations").Cells(Rows.Count, "B").End(xlUp).Row
SigString = "H:\AppData\Roaming\Microsoft\Signatures\"
If Dir(SigString, vbDirectory) <> vbNullString Then
SigString = SigString & Dir$(SigString & "*.htm")
Else:
SigString = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(SigString).OpenAsTextStream(1, -2).readall
If Me.cmbMonth.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Required!"
Me.cmbMonth.SetFocus
Exit Sub
ElseIf Me.txtbxYear.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Required!"
Me.txtbxYear.SetFocus
Exit Sub
ElseIf Me.cmbSubbie.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Required!"
Me.cmbSubbie.SetFocus
Exit Sub
End If
For i = 1 To lastG
lookupVal = Sheets("File Locations").Cells(i, "B") ' value to find
If Dir(lookupVal, vbDirectory) = "" Then
Else
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set itmevt.itm = OutMail
dte = Me.cmbMonth.Value & " " & Me.txtbxYear.Text
myDir = lookupVal 'Set Dir to search
ChDir = (myDir & "\" & Me.cmbSubbie.Value & "\***\") 'Change to that dir
sFName = Dir(ChDir & "*" & dte & "*") 'Set Search spec
While InStr(sFName, dte)
colFiles.Add (ChDir & sFName)
attName.Add (sFName)
sFName = Dir
Wend
End If
Next i
On Error Resume Next
With OutMail
If Me.txtbxSubNAME.Value <> "" Then
cntName = " " & Me.txtbxSubNAME.Value & ","
Else
cntName = ","
End If
If Time < TimeValue("12:00:00") Then
greet = "Good Morning" & cntName
Else
greet = "Good Afternoon" & cntName
End If
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
.Attachments.Add colFiles(i)
attName2 = attName(i) & "<br>" & attName2
Next i
End If
.To = Me.txtbxSubEMAIL.Value
.CC = ""
.BCC = ""
.Subject = Me.cmbMonth.Value & "'s "
.BodyFormat = olFormatHTML
.HTMLbody = "<HTML><BODY STYLE='font-family:Calibri;font-size:14.5'>" & greet & "<br><br>" & "Thank for your . Please see the attached remittances." & "<br><br>" & "<b>" & attName2 & "</b>" _
& "<br>" & "Please submit if you are required to do so. In this email, could you please copy in:" & "<br><br>" & _
"" & "<br><br>" & _
"<b>" & "Please note: " & "</b>" & "If you need to supply a matching invoice and we do not receive one, your payment's will be held." & "<br><br>" & "Kind regards," & "</BODY></HTML>" & .HTMLbody & Signature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Related
I've been looking into trying to use VBA Macro's to send an email through Mozilla Thunderbird with the spreadsheet as an attachment.
///I've searched Google and Stack Overflow itself and none of those solutions seem to be working./// I am not the best at coding or excel itself so I was just wondering if any kind soul could help me out?
Appreciate any help given.
Regards,
Looked at a load more articles and tried following what the comments have said but they didn't help. I have, however, managed to get the email portion of this to work myself. Below is the code I use
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As
String, _
ByVal nShowCmd As Long) As Long
Sub Send_Email_Using_Keys()
Dim Mail_Object As String
Dim Email_Subject, Email_Send_To, Email_Cc, Email_Bcc, Email_Body As String
Email_Subject = "ACT Form Completed and Confirmed"
Email_Send_To = "kieranfarley#achievementtraining.com"
Email_Cc = "kieranfarley#achievementtraining.com"
Email_Bcc = "kieranfarley#achievementtraining.com"
Email_Body = "ACT Form Completed and Confirmed Please see attached"
Mail_Object = "mailto:" & Email_Send_To & "?subject=" & Email_Subject &
"&body=" & Email_Body & "&cc=" & Email_Cc & "&bcc=" & Email_Bcc
On Error GoTo debugs
ShellExecute 0&, vbNullString, Mail_Object, vbNullString, vbNullString,
vbNormalFocus
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End Sub
This opened the 'Write' box in thunderbird with all the fields pre-filled out ready to send.
Found some old code. Not recently tested but it worked with attachments for Thunderbird. You probably have to adapt it to your needs:
'***********************************************************************
'* Send mail with Thunderbird
'*
Option Explicit
'***********************
'* HTML formatting
'*
Private Const STARTBODY = "<html><head><style type='text/css'> body { font: 11pt Calibri, Verdana, Geneva, Arial, Helvetica, sans-serif; } </style></head><body> "
Private Const ENDBODY = "</body></htlm>"
'* Test only
Private Const ATTACHMENT1 = "C:\Temp\attachment1.pdf"
Private Const ATTACHMENT2 = "C:\Temp\attachment2.pdf"
'*******************************************************************************************
'* Test code only. Can be run by placing the cursor anywhere within the code and press F5
'* SetX THUNDERBIRD_PATH "C:\Program Files\Mozilla Thunderbird\thunderbird.exe"
'*
Private Sub MailTest()
Dim Rcp As String
Dim CC As String
Dim BCC As String
Dim Result As Boolean
Rcp = "someone#domain.com"
CC = "someoneelse#domain.com"
BCC = "onedude#domain.com"
Result = SendMail(Rcp, CC, BCC, "Test", "Hello World", False, ATTACHMENT1 & ";" & ATTACHMENT2)
End Sub
'****************************************************************************
'* Send e-mail through Thunderbird
'* SetX THUNDERBIRD_PATH "C:\Program Files\Mozilla Thunderbird\thunderbird.exe"
'*
Function SendMail(strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strMessageBody As String, _
Optional PlainTextFormat As Boolean = False, _
Optional strAttachments As String = "", _
Optional SignatureFile As String = "") As Boolean
Dim Cmd As String
Dim Arg As String
Dim Result As Integer
Dim objOutlook As Outlook.Application
Dim MAPISession As Outlook.NameSpace
Dim MAPIMailItem As Outlook.MailItem
Dim strTemp As String
Dim MailResult As Boolean
Dim I As Integer
Dim Account As Object
MailResult = False
Cmd = Environ("THUNDERBIRD_PATH") 'E:\Program Files\Mozilla Thunderbird\thunderbird.exe
If Cmd <> "" Then ' Thunderbird installed
Arg = " -compose """
strTo = Replace(strTo, ";", ",")
If strTo <> "" Then Arg = Arg & "to='" & strTo & "',"
strCC = Replace(strCC, ";", ",")
If strCC <> "" Then Arg = Arg & "cc='" & strCC & "',"
strBCC = Replace(strBCC, ";", ",")
If strBCC <> "" Then Arg = Arg & "bcc='" & strBCC & "',"
If strSubject <> "" Then Arg = Arg & "subject=" & strSubject & ","
If PlainTextFormat = True Then
strTemp = "2" 'Plain text
Else
strTemp = "1" 'HTML
strMessageBody = STARTBODY & strMessageBody & ENDBODY 'Add HTML and CSS
End If
Arg = Arg & "format=" & strTemp & "," 'Format specifier HTML or Plain Text
Arg = Arg & "body='" & strMessageBody & "'," 'Add body text
Call AddSignature(SignatureFile, strMessageBody) 'Add signature if any
Arg = Arg & "attachment='"
Call AddAttachments(strAttachments, , Arg) 'Add attachment(s) if any
Arg = Arg & "'""" 'Closing quotes
Shell Cmd & Arg 'Call Thunderbird to send the message
MailResult = True
SendMail = MailResult
End Function
'*******************************************************************
'* Add recipients, CC or BCC recipients to the email message
'* Recipients is a string with one or more email addresses,
'* each separated with a semicolon
'* Returns number of addresses added
'*
Private Function AddRecipients(Recipients As String, MAPIMailItem As Outlook.MailItem, RecType As Integer) As Integer
Dim OLRecipient As Outlook.Recipient
Dim TempArray() As String
Dim Recipient As Variant
Dim Emailaddr As String
Dim Count As Integer
Count = 0
TempArray = Split(Recipients, ";")
For Each Recipient In TempArray
Emailaddr = Trim(Recipient)
If Emailaddr <> "" Then
Set OLRecipient = MAPIMailItem.Recipients.Add(Emailaddr)
OLRecipient.Type = RecType
Set OLRecipient = Nothing
Count = Count + 1
End If
Next Recipient
AddRecipients = Count
End Function
'******************************************************
'* Add possible signature to the email message
'* Returns True if signature added
'*
Private Function AddSignature(SignatureFile As String, ByRef strMessageBody As String) As Boolean
Dim Signature As String
Dim Tempstr As String
Dim Added As Boolean
Added = False
If SignatureFile <> "" Then
Signature = ""
Open SignatureFile For Input As #1 'Open file for reading
Do While Not EOF(1) 'Loop through file
Input #1, Tempstr 'One line
Signature = Signature & Tempstr 'Add it
Loop
Close #1
strMessageBody = strMessageBody & Signature 'Add to message
Added = True
End If
AddSignature = Added
End Function
'******************************************************
'* Add possible attachments to the email message
'* Returns number of attachments added
'*
Private Function AddAttachments(ByRef strAttachments As String) As Integer
Dim TempArray() As String
Dim Attachment As Variant
Dim Tempstr As String
Dim Count As Integer
Count = 0
TempArray = Split(strAttachments, ";")
For Each Attachment In TempArray
Tempstr = CStr(Trim(Attachment))
If Tempstr <> "" Then
If Count > 0 Then Arg = Arg & ","
Arg = Arg & "file:///" & Tempstr
End If
Count = Count + 1
Next Attachment
AddAttachments = Count
End Function
The code below iterates through a range in excel and for each record marked for sending it will send an email using Thunderbird. Additionally, if the path to a file is specified it will attach that file. Be careful with the apostrophes when building the command string. If you get them wrong the non-printing characters will be removed from the message body for some reason.
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim contactRange As Range, cell As Range
Dim count As Integer
Dim thund As String
Dim email As String
Dim recipientName As String
Dim pathToThunderBird
Set contactRange = Range("ContactYesNo")
pathToThunderBird = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe "
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
recipientName = cell.Offset(0, 2).Value
email = cell.Offset(0, 6).Value
emailMsg = "Hi " & recipientName & vbCrLf & vbCrLf & msg & vbCrLf
'You'll want to change the salutation.
thund = pathToThunderBird & _
"-compose " & """" & _
"to='" & email & "'," & _
",subject='" & subject & "'," & _
",body='" & emailMsg & vbCrLf & vbCrLf & _
"Your Name" & vbCrLf & _
"123.456.7890" & "'" & """"
If path = "" Then 'no attachment
'do nothing
Else 'with attachment
thund = thund & ",attachment=" & path
End If
Call Shell(thund, vbNormalFocus)
'comment this out if you do not want to send automatically
SendKeys "^+{ENTER}", True
End If
Next cell
End With
End Sub
I have a vba code that scan image from scanner , the code works and doesnt have any problem with type hp an brother scanner but when I used it with canon can not find the scanner and send message no wia device. How can solve this problem
Private Sub Command10_Click()
Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
On Error GoTo Handle_Err
Dim Dialog1 As New WIA.CommonDialog, DPI As Integer, PP As Integer, l As Integer
Dim Scanner As WIA.Device
Dim img As WIA.ImageFile
Dim intPages As Integer
Dim strFileJPG As String
Dim blnContScan As Boolean ' to activate the scanner to start scan
Dim ContScan As String 'msgbox to chk if more pages are to be scanned
Dim strFilePDF As String
Dim RptName As String
Dim strProcName As String
strProcName = "ScanDocs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp"
DoCmd.SetWarnings False
blnContScan = True
intPages = 0
Do While blnContScan = True
DPI = 200
PP = 1 'No of pages
Set Scanner = Dialog1.ShowSelectDevice(WIA.WiaDeviceType.ScannerDeviceType, True, False)
Set img = Dialog1.ShowTransfer(Scanner.Items(1), wiaFormatJPEG, True)
strFileJPG = ""
intPages = intPages + 1
strFileJPG = "\\User-pc\saveimage\" & num & Trim(str(intPages)) & ".jpg"
img.SaveFile (strFileJPG)
DoCmd.RunSQL "insert into scantemp (picture) values ('" & strFileJPG & "')"
DoCmd.SetWarnings False
Set Scanner = Nothing
Set img = Nothing
' strFileJPG = ""
'Prompt user if there are additional pages to scan
ContScan = MsgBox("?save another page ", vbQuestion + vbYesNoCancel)
If ContScan = vbNo Then
blnContScan = False
ElseIf ContScan = vbCancel Then
DoCmd.RunSQL "delete from scantemp where picture = '" & strFileJPG & "'"
End If
'''''''''''''''
Loop
Dim Image_Path As String
GoTo StartPDFConversion
StartPDFConversion:
Dim s As String
strFilePDF = "\\User-pc\saveimage\" & (num) & ".pdf"
RptName = "rptScan"
DoCmd.OpenReport RptName, acViewReport, , , acHidden
DoCmd.Close acReport, RptName, acSaveYes
DoCmd.OutputTo acOutputReport, RptName, acFormatPDF, strFilePDF
Me.imgp = strFilePDF
DoCmd.RunSQL "delete from scantemp" 'delete all data from table scantemp after converted it to pdf
'/*******************************\
'/********************************************\
Handle_Exit:
Exit Sub
Handle_Err:
Select Case Err.Number
Case 2501
Resume Handle_Exit
Case Else
MsgBox "the." & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, 0, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume Handle_Exit
End Select
Exit Sub
End Sub
Option Compare Database
Private Declare Function TWAIN_AcquireToFilename Lib "TWAIN32d.DLL" (ByVal hwndApp As Long, ByVal bmpFileName As String) As Integer
Private Declare Function TWAIN_IsAvailable Lib "TWAIN32d.DLL" () As Long
Private Declare Function TWAIN_SelectImageSource Lib "TWAIN32d.DLL" (ByVal hwndApp As Long) As Long
Private Sub cmdScan_Click()
Dim Ret As Long, PictureFile As String
Dim intPages As Integer
Dim blnContScan As Boolean
Dim ContScan As String 'msgbox to chk if more pages are to be scanned
blnContScan = True
intPages = 0
Do While blnContScan = True
DPI = 200
PP = 1 'No of pages
intPages = intPages + 1
PictureFile = CurrentProject.Path & "\" & myfolder & "\" & Me.number & Trim(Str(intPages)) & ".jpg"
Ret = TWAIN_AcquireToFilename(Me.hwnd, PictureFile)
ContScan = MsgBox("? ÍÝÙ ÕæÑÉ ÇÎÑì ", vbQuestion + vbYesNo, "ÊäÈíÉ")
If ContScan = vbNo Then
blnContScan = False
End If
Loop
Hello can you help me please with code in VBA ? I would like create a log file from text in cells ("C2" and "C3 " + date and time ) when I press button "zadat" Thank you
My code for implementation is:
Module 1
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zadat()
Dim reg, check As String
Dim i, j, done As Integer
reg = Cells(2, 3).Value
check = Cells(4, 3).Value
If check = "True" Then
i = 2
j = 1
done = 0
Do While Sheets("data").Cells(i, j) <> ""
If Sheets("data").Cells(i, j) = reg Then
vytisteno = ZkontrolovatAVytiskoutSoubor()
done = Sheets("data").Cells(i, j + 3)
done = done + 1
Sheets("data").Cells(i, j + 3) = done
Exit Do
End If
i = i + 1
Loop
Else
MsgBox ("Opravit, špatný štítek!!!")
End If
Cells(3, 3) = ""
Cells(3, 3).Select
ActiveWindow.ScrollRow = Cells(1, 1).row
End Sub
Module 2:
Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Function PrintThisDoc(formname As Long, FileName As String)
On Error Resume Next
Dim x As Long
x = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)
End Function
Public Function ZkontrolovatAVytiskoutSoubor() As Boolean
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "W:\Etikety\Štítky\Krabice\Testy"
strFile = Range("C2").Value & ".lbe"
If Not FileExists(strDir & "\" & strFile) Then
MsgBox "soubor neexistuje!"
ZkontrolovatAVytiskoutSoubor = False
Else
printThis = PrintThisDoc(0, strDir & "\" & strFile)
ZkontrolovatAVytiskoutSoubor = True
End If
End Function
Private Function FileExists(fname) As Boolean
'Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function
If you don't want to use FSO, there is a simple solution using only VBA statements: Open, Print # and Close:
Sub Log2File(Filename As String, Cell1, Cell2)
Dim f As Integer
f = FreeFile
Open Filename For Append Access Write Lock Write As #f
Print #f, Now, Cell1, Cell2
Close #f
End Sub
I've put the filename and the cells refs as arguments of the sub for re-usability purpose. I also use default (local) formatting, but this can be easily changed.
Note that you don't have to check for existence of the file, it will be created if it doesn't exist.
Try this. Below code will create a new log file every time
Public Function LogDetails()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim logFile As Object
Dim logFilePath As String
Dim logFileName As String
'Replace 'TestLog' with your desired file name
logFileName = "TestLog" & ".txt"
myFilePath = "C:\Users\..\Desktop\" & logFileName 'Modify the path here
If fso.FileExists(myFilePath) Then
Set logFile = fso.OpenTextFile(myFilePath, 8)
Else
' create the file instead
Set logFile = fso.CreateTextFile(myFilePath, True)
End If
logFile.WriteLine "[" & Date & " " & Time & "] " & Worksheet("yoursheetnamehere").Cells(2, 3) & " " & Worksheet("yoursheetnamehere").Cells(3, 3)
logFile.Close ' close the file
End Function
I have this code to send mail to multiple recipients using Lotus Notes. Right now I need to mention the entire file path for the attachments. My requirement is to use FileSearch method - mention any part of the name of the attachment within * * - so that the files get attached.
Sub Send()
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim direct As Object
Dim Var As Variant
Dim flag As Boolean
Dim cell As Range
Dim r As Excel.Range
Dim Name As String
Dim Annex As String
Dim recp As Variant
Dim cc As Variant
Dim Resp As Long
Resp = MsgBox(prompt:="Do you wish to send to the mail?", Buttons:=vbYesNo + vbInformation + vbDefaultButton2, Title:=AppHeader)
If Resp = vbYes Then
Sheets("Sheet2").Activate
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "E").Value) = "yes" Then
Set oSess = CreateObject("Notes.NotesSession")
Set oDB = oSess.GETDATABASE("", "")
Call oDB.OPENMAIL
flag = True
If Not (oDB.IsOpen) Then flag = oDB.Open("", "")
If Not flag Then
MsgBox "Can't open mail file: " & oDB.SERVER & " " & oDB.FILEPATH
GoTo exit_SendAttachment
End If
On Error GoTo err_handler
'Building Message
recp = Cells(cell.Row, "B").Value
cc = Cells(cell.Row, "C").Value
Set oDoc = oDB.CREATEDOCUMENT
Set oItem = oDoc.CREATERICHTEXTITEM("BODY")
oDoc.Form = "Memo"
oDoc.Subject = "HI" & "-" & Cells(cell.Row, "D").Value
oDoc.sendto = Split(recp, ",")
oDoc.copyto = Split(cc, ",")
oDoc.body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please find attached "
oDoc.postdate = Date
oDoc.SaveMessageOnSend = True
Name = Cells(cell.Row, "F").Value
Annex = Cells(cell.Row, "G").Value
Call oItem.EmbedObject(1454, "", Name)
Call oItem.EmbedObject(1454, "", Annex)
oDoc.Send False
End If
Next cell
MsgBox prompt:="Mail Sent", Buttons:=vbOKOnly + vbInformation, Title:=AppHeader
Exit Sub
'Attaching DATABASE
For Each r In Range("Fpath") '// Change to suit
If r.Value <> vbNullString Then
Call Send
End If
Next
oDoc.visable = True
'Sending Message
exit_SendAttachment:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
'Done
err_handler:
If Err.Number = 7225 Then
MsgBox "File doesn't exist"
Else
MsgBox Err.Number & " " & Err.Description
End If
On Error GoTo exit_SendAttachment
Else
Sheets("Sheet1").Activate
End If
End Sub
Any thoughts will be highly appreciated.
It's been years since I have worked with Lotus notes. The last question that I answered on Lotus notes was way back in July 26, 2011 So be gentle on me if I miss any syntax. :p
Application.FileSearch method is no longer supported from XL2007+
Reference: Error message when you run a macro to search for a file in an Office 2007 program: "Run-time error 5111"
In case the above link dies, here is the screenshot.
As mentioned in that link You can use the FileSystemObject object to recursively search directories and to find specific files. Here is how we do that
In case the above link dies, here is the code from that link.
'~~> COURTESY: http://support.microsoft.com/kb/185601
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = InputBox("Type the directory that you want to search for", _
"FileSystemObjects example", "C:\")
sSrchString = InputBox("Type the file name that you want to search for", _
"FileSystemObjects example", "vb.ini")
MousePointer = vbHourglass
Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
" directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
FileName))
nFiles = nFiles + 1
List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
Once you are able to select the files you can use the below code in a loop to add the attachments
stAttachment = "Blah Blah.Txt"
Set obAttachment = oDoc.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
With my code I have to write a file name to search : "test.txt" . It works fine, returns as many as test.txt exist in the selected path.
I want it to work searching : "txt" and get all the .txt files in the selected path.
My code :
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = InputBox("Type the directory that you want to search for", _
"FileSystemObjects example", "C:\")
sSrchString = InputBox("Type the file name that you want to search for", _
"FileSystemObjects example", "")
' MousePointer = vbHourglass
' Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
' MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
" directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.path, _
FileName))
nFiles = nFiles + 1
' List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
' Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
and a tip, I've found something like :
For Each file In files
If Right(file, 3) = "pdf" Then
myMailItem.Attachments.Add CStr(file)
found = True
End If
But I couldn't get it working in my code.
Thanks!