when i search in the name fill-in with a starting letter of a name it should display all the name starting with that letter.
TIP: it should use open query`
DO:
IF (input customer.cust-num <> 0) and (input customer.name = "") then do:
find first customer where ( customer.cust-num = input cust-num) no-error.
OPEN QUERY custqry FOR EACH customer.
display customer.cust-num customer.name customer.balance customer.discount customer.credit-limit customer.phone customer.contact with browse br1 . /*to display in browser*/
assign
ocustnum = customer.cust-num
oName = customer.Name
obalance = customer.balance
odiscount = customer.discount
ocredit-limit = customer.credit-limit
ophone = customer.phone
ocontact = customer.contact .
display ocustnum oName obalance odiscount ocredit-limit ophone ocontact with frame default-frame . /*to display in fillin*/
end.
ELSE IF (input customer.cust-num = 0) and (input customer.name <> "") then do:
find first customer where customer.name begins input name no-error .
OPEN QUERY q FOR EACH customer BY name.
display customer.cust-num customer.name customer.balance customer.discount customer.credit-limit customer.phone customer.contact with browse br1. /*to display in browser*/
assign
ocustnum = customer.cust-num
oName = customer.Name
obalance = customer.balance
odiscount = customer.discount
ocredit-limit = customer.credit-limit
ophone = customer.phone
ocontact = customer.contact .
display ocustnum oName obalance odiscount ocredit-limit ophone ocontact with frame default-frame . /*to display in fillin*/
end.
ELSE IF (input customer.cust-num <> 0) and (input customer.name <> "") then do:
find first customer where ( customer.cust-num = input cust-num) and (customer.name begins input name) no-lock no-error .
OPEN QUERY cust-query FOR EACH customer BY name.
display customer.cust-num customer.name customer.balance customer.discount customer.credit-limit customer.phone customer.contact with browse br1. /*to display in browser*/
assign
ocustnum = customer.cust-num
oName = customer.Name
obalance = customer.balance
odiscount = customer.discount
ocredit-limit = customer.credit-limit
ophone = customer.phone
ocontact = customer.contact .
display ocustnum oName obalance odiscount ocredit-limit ophone ocontact with frame default-frame . /*to display in fillin*/
end.
END.
`
the above code i have written for the search button.enter image description here
Use BEGINS to match the start of a string and use BY to control sorting order:
OPEN QUERY q FOR EACH customer
WHERE customer.name BEGINS (INPUT customer.name) BY name.
Related
I got a question, a couple in fact. (sorry for not formatting correctly, i tried but it just doesnt "work")
I've designed a template for my job application processes, got the content controls working fine pushing data from my form to the document.
Now i wonder, how to retrieve such data back into the form when i open the document again?
Working short word code:
Option Explicit
'Coded by Etrola Limited-Now terminated /Erik L Thoresen
'Pending change
'Revision 1 CC and form
Private Sub cmdFillForm_Click()
'Fill letter elements (content controls) from userform, works fine to fill text in controls
Dim cc As ContentControl
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccCompany" Then
cc.Range.Text = Me.txtCompany
Exit For
End If
Next cc
End Sub
How should I then best place code to place this?
Debug.Print cc.Range.text to keep my form "live to data in doc?"
And now for my second question: In my Excel database, a log of different activities performed, i got the urge of creating my application from a range of declared cells as filename, and the data from those shall also be entered into content controls when calling the form to create a new application with a filename given by these ranged cells. Lets say:
I have an active line in a table in that sheet, the last row with 5 or more cells in a row.
I can also have entered any number of interesting jobs for a date, and by a click of a floating or other form of way to create these applications type of menu, all are created with the desired data.
How do i call that template?
How do i define either ranged cells (by date would be nice, but also ActiveRow)?
Excel code:
Option Explicit
Sub TransferDataToWord()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim strDocName As String
Dim MyRange As Range
Dim fNamePt1 As String
Dim fNamePt2 As String
Dim fNamePt3 As String
Dim fNamePt4 As String
Dim fNamePt5 As String
fNamePt1 = Range.Count '?
fNamePt2 = Range.Count '?
fNamePt3 = Range.Count '?
fNamePt4 = Range.Count '?
fNamePt5 = Range.Count '?
On Error Resume Next
Set wdApp = GetObject(, "word.application")
Set wdDoc = wdApp.Documents.Add
wdDoc.Content.InsertAfter Range
If Err.Number = 429 Then
Err.Clear
Set wdApp = CreateObject("word.application")
End If
wdApp.Visible = True
strDocName = "C:\Myfolder\" 'Søknad' "&fNamePt1 &fNamePt2 &fNamePt3 &fNamePt4)
If Dir(strDocName) = "" Then
MsgBox "The file " & strDocName & vbCrLf & "wasn't found " & vbCrLf & "C:\MyFolder\.", vbExclamation, " The document doesn't exist "
End Sub
End If
wdApp.Activate
Set wdDoc = wdApp.Documents(strDocName)
If wdDoc Is Nothing Then
Set wdDoc = Documents(strDocName)
wdDoc.Activate
wdDoc.MyRange.Paste
wdDoc.Save
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Application.CutCopyMode = False
Thank you for your reply.
Now, for calling this word template from a embedded button in my excel sheet =EMBED("Forms.CommandButton.1";"") named cmdCreateApplication, should i better use like this:
`oWord.Documents.Add "<Path to my template>\MyTemplate.dot"`
or your example?
My code now looks like this:(Yet to make it work) I know i have gotten something wrong. Since i've forgotten too much.
Private Sub cmdCreateApplication_Click(ByVal oRng As Range)
'
'Opens desired template to fill in data form range of cells
'Dim wApp As Word.Application
Set wApp = CreateObject(, "Word.Application")
wApp.DisplayAlerts = False
'Opens template to create document
Documents.Add Template:="C:\myfolder\Norwegian Application Template 2.dotm"
'Below Tells to keep values in memory
Dim MyDate As String
Dim MyJobTitle As String
Dim MyDocType As String
Dim MyJobRefNo As String
Dim TheirRefNo As String
Dim JobWebSite As String
Dim Company As String
Dim AttName As String
Dim AttTitle As String
Dim AttEmail As String
Dim RecFirm As String
Dim Address As String
'Below Describes what to extract from Excel and keep in memory to fill into word document objects
MyDate = oRng.Offset(0, 1).Text 'Date of application /first contact
MyDocType = oRng.Offset(0, 5).Text 'File name part 1 Identifier of doc type, if application, e-mail or CV
MyJobTitle = oRng.Offset(0, 6).Text 'File name part 2 Job title
RecFirm = oRng.Offset(0, 15).Text 'File name part 3 Recruitment agancy, if exist
Company = oRng.Offset(0, 16).Text 'File name part 4 Hiring Company, if exist
MyJobRefNo = oRng.Offset(0, 8).Text 'File name part 5 Reference number (if website)
AttName = oRng.Offset(0, 11).Text 'Contact name
AttEmail = oRng.Offset(0, 13).Text 'Contact e-mail
AttTitle = oRng.Offset(0, 12).Text 'Contact title
JobWebSite = oRng.Offset(0, 10).Text 'Link to job board
TheirRefNo = oRng.Offset(0, 9).Text 'Their reference nr if any
Address = oRng.Offset(0, 17).Text 'Company Adress
On Error Resume Next
'
Set wdApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
Set wdApp = CreateObject("Word.Application")
End If
strDocName = "C:\myfolder\ MyDocType &wdKeySpacebar &MyJobTitle &wdKeySpacebar &RecFirm &wdKeySpacebar &Company &wdKeySpacebar &MyJobRefNo"
'Below describes where stored data shall be placed before assigning file name and save
Dim cc As ContentControl
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccCompany" Then
Company = Me.txtCompany 'Fills data into form
Company = cc.Range.Text 'Fills data into content controls
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccDate" Then
MyDate = Me.txtApplicationDate
MyDate = cc.Range.Text
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccJobTitle" Then
MyJobTitle = Me.txtJobTitle
MyJobTitle = cc.Range.Text
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccRecFirm" Then
RecFirm = Me.txtRecFirm
RecFirm = cc.Range.Text
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccJobWebSite" Then
JobWebSite = cc.Range.Text
JobWebSite = Me.txtJobPostWeb
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAttEmail" Then
AttEmail = cc.Range.Text
AttEmail = Me.txtAttEmail
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAttTitle" Then
AttTitle = cc.Range.Text
AttTitle = Me.txtAttTitle
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAttName" Then
AttName = cc.Range.Text
AttName = Me.txtAttName
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccTheirRefNo" Then
TheirRefNo = cc.Range.Text
TheirRefNo = Me.txtTheirRefNo
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccMyRefNo" Then
MyJobRefNo = cc.Range.Text
MyJobRefNo = Me.txtMyJobRefNo
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAddress" Then
Address = cc.Range.Text
Address = Me.txtCompanyStreetAddress
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccRequirements" Then
Requirements = cc.Range.Text
Requirements = Me.txtRequirements
Exit For
End If
Next cc
End Sub
To keep the form synchronized with the document, I would place some code in the forms Open() event, doing exactly the opposite assignment:
Private sub Form_open()
Dim cc As ContentControl
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccCompany" Then
Me.txtCompany = cc.Range.Text
Exit For
End If
Next cc
End Sub
I'm afraid I don't fully understand your second question, but I think in this case I would pass the Range object as a parameter to the function that creates the Word document. This way you divide the responsibilities between different procedures.
Sub TransferDataToWord(byval oRng as Range)
...
fNamePt1 = oRng.Offset(0,1).Text
fNamePt2 = oRng.Offset(0,2).Text
...
On error resume next
Set wdApp = GetObject(,"Word.Application")
If Err.Number = 429 Then
Err.Clear
Set wdApp = CreateObject("Word.Application")
End If
...
Hope you find what you're looking for.
Regards.
I have a form in which you introduce the product code and it returns its description and price. I would like to add another search criteria to be able to look for the product by keyword, searching in the "description" column. I'm not sure whether the "find" function allows doing this, or if I need to use the "vlookup" function. The problem that I found with "vlookup" is that I would like to be able to keep searching in the column for the rest of the matchs. This is the code that I have working at the moment:
Option Explicit
Dim Llave As Boolean
Private Sub BtnBuscar_Click()
If Not Sheet1.Range("C1:C211").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
If Llave Then
Cells.FindNext(After:=ActiveCell).Select
Fila.Caption = ActiveCell.Row
Dato1.Caption = ActiveCell.Value
Dato2.Caption = ActiveCell.Offset(0, 1).Value
Dato3.Caption = ActiveCell.Offset(0, 2).Value
Dato4.Caption = ActiveCell.Offset(0, 4).Value
Else
Sheet1.Range("C1:C211").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Select
Fila.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Row
Dato1.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Value
Dato2.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Value
Dato3.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 2).Value
Dato4.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 4).Value
Llave = True
End If
Else
Dato1.Caption = " "
Dato2.Caption = " "
Dato3.Caption = " "
Dato4.Caption = " "
Fila.Caption = " "
MsgBox "Dato Inexistente", 64, ""
End If
End Sub
Private Sub Dato1_Click()
End Sub
Private Sub Dato3_Click()
End Sub
Private Sub Fila_Click()
End Sub
Private Sub UserForm_Initialize()
Llave = False
End Sub
So it's a search form (Userform) that I pop up when clicking a button on the worksheet (shee1).
Thanks a lot in advance!
Natalia.
I would suggest using Find in a DO UNTIL loop until the range returned by find is nothing and use that loop to populate a listbox. Then the user can select the match that the want.
I have a script to auto email a list of address' stored in Excel, but it is only sending to the first address and not looping to the rest, I cannot seem to fix it:
Set objMessage = CreateObject("CDO.Message")
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
email = sh.Range("A" & row)
LastRow = sh.UsedRange.Rows.Count
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim f
Set f = fso.OpenTextFile("Y:\Billing_Common\autoemail\Script\Email.txt", ForReading)
BodyText = f.ReadAll
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
objMessage.Subject = "Billing: Meter Read"
objMessage.From = "billing#energia.ie"
row = row + 1
objMessage.To = email
objMessage.TextBody = BodyText
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "SERVER ADDRESS HERE"
'Server port
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
End if
Next
f.Close
Set f = Nothing
Set fso = Nothing
wb.Close
End If
Next
Any help would be much appreciated guys!
Thanks!
row = 2
email = sh.Range("A" & row)
...
For r = row to LastRow
...
objMessage.To = email
...
Next
You set email to the value of the cell "A2" and never change it. If you want to send a mail to multiple recipients, you should make that
objMessage.To = sh.Range("A" & r).Value
or (better) build a recipient list (assuming that your used range starts with headers in the first table row):
ReDim recipients(LastRow - row)
For r = row To LastRow
recipients(r - row) = sh.Range("A" & r).Value
Next
objMessage.To = Join(recipients, ";")
and send the message just once. The MTA will handle the rest.
Side note: as Vishnu Prasad Kallummel pointed out in the comments your code doesn't close the Excel instance it started. Unlike other objects created in VBScript, Office applications won't automatically terminate with the script, so you have to handle it yourself:
...
wb.Close
app.Quit
I have a excel form which works and saves data to just one worksheet. I like to be able to put a radio button and based on that selection i like to save to a diffent work sheet.
example:
if radio button 1 is selected save to sheet1
if radio button 2 is selected save to sheet2
if radio button 3 is selected save to sheet3
same form used to save on different worksheet.
the code im working with.
Private Sub btn_append_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Assessment")
'find first empty row in database
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'check for a part number
If Trim(Me.txt_roomNumber.Value) = "" Then
Me.txt_roomNumber.SetFocus
MsgBox "Please enter a Room Number"
Exit Sub
End If
'copy the data to the database
'use protect and unprotect lines,
' with your password
' if worksheet is protected
With ws
' .Unprotect Password:="password"
.Cells(iRow, 1).Value = Me.txt_roomNumber.Value
.Cells(iRow, 2).Value = Me.txt_roomName.Value
.Cells(iRow, 3).Value = Me.txt_department.Value
.Cells(iRow, 4).Value = Me.txt_contact.Value
.Cells(iRow, 5).Value = Me.txt_altContact.Value
.Cells(iRow, 6).Value = Me.cbx_devices.Value
.Cells(iRow, 7).Value = Me.cbx_wallWow.Value
.Cells(iRow, 8).Value = Me.txt_existingHostName.Value
.Cells(iRow, 10).Value = Me.cbx_relocate.Value
If Me.ckb_powerbar.Value = True Then Cells(iRow, 11).Value = "Y"
If Me.ckb_dataJackPull.Value = True Then Cells(iRow, 12).Value = "P"
.Cells(iRow, 13).Value = Me.txt_existingDataJack.Value
If Me.ckb_hydroPull.Value = True Then Cells(iRow, 14).Value = "P" Else Cells(iRow, 14).Value = "A"
.Cells(iRow, 19).Value = Me.txt_cablePullDesc.Value
.Cells(iRow, 20).Value = Me.txt_hydroPullDesc.Value
.Cells(iRow, 21).Value = Me.Txt_otherDesc.Value
' .Protect Password:="password"
End With
'clear the data
'Me.txt_roomNumber.Value = ""
'Me.txt_roomName.Value = ""
'Me.txt_department.Value = ""
'Me.txt_contact.Value = ""
'Me.txt_altContact.Value = ""
Me.cbx_relocate.Value = ""
Me.txt_existingHostName = ""
Me.txt_altContact.SetFocus
End Sub
Private Sub btn_close_Click()
Unload Me
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the Close Form button!"
End If
End Sub
The first thing to do is to add the radio-buttons (actually OptionButton) to the form and name them.
Then to check if one of them is selected use code such as:
If optSheet1 Then
'it is checked
ElseIf optSheet2 Then
'the second one is checked
'etc
End If
I have the following code, my goal is to send automatic emails to a list of people in an excel document, using a text file as a template:
Set objMessage = CreateObject("CDO.Message")
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("F:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
email = sh.Range("A" & row)
subject = "Billing"
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
objMessage.Subject = "Billing: Meter Read"
objMessage.From = "billing#energia.ie"
objMessage.To = email
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim emailText
Set emailText = fso.OpenTextFile("F:\Billing_Common\autoemail\Script\Email.txt", ForReading)
BodyText = emailText.ReadAll
objMessage.TextBody = emailText
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = CdoSendUsingPort
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "ADDRESS OF SERVER HERE"
'Server port
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
End if
Next
emailText.Close
Set emailText = Nothing
Set fso = Nothing
wb.Close
End If
Next
It throws an error at the objMessage.TextBody, saying type mismatch. If anyone could help me it would be much appreciated!
Thanks!
For sending inline images you need to create an HTMLBody instead of a TextBody and add a RelatedBodyPart with the image (see here):
Set msg = CreateObject("CDO.Message")
...
msg.HTMLBody = "<html>" & vbLf & _
"<head><title>Test</title></head>" & vbLf & _
"<body><p><img src='foo.jpg'></p></body>" & vbLf & _
"</html>"
msg.AddRelatedBodyPart "C:\path\to\your.jpg", "foo.jpg", 0
After the line BodyText = emailText.ReadAll, you ought to assign that, and not the file ("emailText" is the TextFile that was Opened by fso on the previous line), that's why it's complaining about a Type Mismatch...
So just replace objMessage.TextBody = emailText with objMessage.TextBody = BodyText and it should work...