Very simple problem needs sorting

We have a number of Visual Basic scripts that we use to take information from our SQL database.

The bib on this is to fix one problem but if we get on there are a few other items I need to get sorted.

Around the 6th December last year there must have been an update as several scripts stopped working on the same day.

The script attached sends a copy of our stock to people in a database. The system cannot locate the resource specified is the error message.

It is creating the CSV as I can see a new copy every time I run the script.

However it seems there is some problem when it interfaces with the Access database and sends the email out.

We can give access to view the live situation to the successful bidder by Team viewer after 17.30pm UK time until 8.00am UK time.

## Deliverables

'

Private Function MailSend(sEmail As String, sDisplayName As String) As Boolean

On Error GoTo ErrTrap

Dim cdoobj, iConf, iFields, Str

MailSend = False

Set cdoobj = CreateObject("[login to view URL]")

Set iConf = CreateObject("[login to view URL]")

Set iFields = [login to view URL]

[login to view URL]("[login to view URL]") = 2 '2 '2 ' SMTP

[login to view URL]("[login to view URL]") = "[login to view URL]"

[login to view URL]("[login to view URL]") = 1 '1

[login to view URL]("[login to view URL]") = 25 '465 '25

[login to view URL]("[login to view URL]") = "Sales@[login to view URL]"

[login to view URL]

Set [login to view URL] = iConf

Str = vbNullString

'please modify as you need

[login to view URL] = "Ability AV-Automated Feeds<Sales@[login to view URL]>"

[login to view URL] = sDisplayName & " <" & sEmail & ">"

[login to view URL] = ""

[login to view URL] = "HIDDEN SEE ON SERVER COPY"

[login to view URL] = "Automated Email do not repond"

[login to view URL] = "Your Ability Stock Feed is attached"

[login to view URL] = sContent

[login to view URL] [login to view URL] & "\[login to view URL]"

[login to view URL]

MailSend = True

Exit Function

ErrTrap:

MailSend = False

End Function

Private Sub Form_Load()

'settings to server

''''''''''''''''''''''''''''''''''''''''''''''''''''''

SQLserverAddress = "mainserverpc\ADVANCEPRO"

SQLserverUsername = "sa"

SQLserverPassword = "XXXXXXXXXXXX- ASK FOR PASSWORD"

SQLdatabaseName = "Advance"

sendToLoc = "[login to view URL]"

destinationFile = "[login to view URL]"

''''''''''''''''''''''''''''''''''''''''''''''''''''''

dbstring = "DRIVER={SQL Server};SERVER=" & SQLserverAddress & ";UID=" & SQLserverUsername & ";password=" & SQLserverPassword & ";APP=Microsoft (R) Developer Studio;LANGUAGE=us_english;DATABASE=" & SQLdatabaseName

Set con = CreateObject("[login to view URL]"): ''con.commandTimeout=000

[login to view URL] dbstring

sqlstr = "SELECT p.c002_product_sku AS partno, c.c001_category_name, p.c002_product_name, i.C014_avail_quantity, p.C002_CUSTOM_FIELD2, "

sqlstr = sqlstr & "c002_product_image, c002_product_icon, c002_product_description_long AS prod_desc_short, c002_product_description_long, "

sqlstr = sqlstr & "c.c001_category_description, CASE when c.c001_active = 1 then 0 else 1 END as cat_hideonosite, "

sqlstr = sqlstr & "pc.C003_bubble_no as prodranking, CASE when c002_active = 1 then 0 else 1 END as prod_hideonosite, "

sqlstr = sqlstr & "'' as template, '' as pdf, c002_cost_price, c002_suggested_retail_price, p.c002_weight, p.c002_min_purchase_qty, "

sqlstr = sqlstr & "p.c002_reorder_alert_level, i.C014_AVAIL_quantity "

sqlstr = sqlstr & "FROM T002_PRODUCTS p "

sqlstr = sqlstr & "INNER JOIN T003_PRODUCT_CATEGORY pc ON p.C002_product_id = pc.C003_product_id "

sqlstr = sqlstr & "INNER JOIN T001_CATEGORIES c ON pc.C003_category_id = c.C001_category_id "

sqlstr = sqlstr & "INNER JOIN T014_INVENTORY i ON p.C002_product_id = i.C014_product_id "

sqlstr = sqlstr & "WHERE [login to view URL] = 1 "

sqlstr = sqlstr & "AND c.c001_active = 1"

sqlstr = sqlstr & " Order by c.c001_category_name, p.c002_product_name"

''

Set supplierRS = [login to view URL](sqlstr)

csvStr = "partno, category_name, product_name, Stock_Available , Trade Price" & vbCrLf

Do While Not [login to view URL]

csvStr = csvStr & supplierRS("partno") & "," & supplierRS("c001_category_name") & "," & supplierRS("c002_product_name") & "," & supplierRS("C014_avail_quantity") & "," & supplierRS("C002_CUSTOM_FIELD2") & vbCrLf

[login to view URL]

Loop

Set supplierRS = Nothing

Set con = Nothing

Dim FSO

Set FSO = CreateObject("[login to view URL]")

Set APfile = [login to view URL](destinationFile, True)

[login to view URL] csvStr

[login to view URL]

If sendToLoc <> "" Then

Set xmlhttp = CreateObject("msxml2.ServerXMLHTTP.3.0")

'Set xmlhttp = CreateObject("[login to view URL]")

[login to view URL] "POST", sendToLoc, False

[login to view URL] "Content-Type", "application/x-www-form-urlencoded"

[login to view URL] "csv=" & URLEncode(csvStr)

Set xmlhttp = Nothing

End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''

'sending emails

Dim cn As New [login to view URL]

[login to view URL] "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & [login to view URL] & "\[login to view URL];Persist Security Info=False"

Dim rec As New [login to view URL]

[login to view URL] "select * from CUS", cn

Do While Not [login to view URL]

' Call MailSend(rec("EMAIL"), rec("NAME"))

[login to view URL]

Loop

End

End Sub

Function URLEncode(sRawURL)

Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz:/.?=_-$(){}~&"

If Len(sRawURL) > 0 Then

' Loop through each char

For iLoop = 1 To Len(sRawURL)

sTmp = Mid(sRawURL, iLoop, 1)

If InStr(1, sValidChars, sTmp, vbBinaryCompare) = 0 Then

' If not ValidChar, convert to HEX and p

' refix with %

sTmp = Hex(Asc(sTmp))

If sTmp = "20" Then

sTmp = "+"

ElseIf Len(sTmp) = 1 Then

sTmp = "%0" & sTmp

Else

sTmp = "%" & sTmp

End If

End If

sRtn = sRtn & sTmp

Next

URLEncode = sRtn

Else

URLEncode = ""

End If

End Function

Дизайн блогів Дизайн іконок Архітектура ПЗ Шаблони Веб-дизайн Робочій стіл Windows

ID Проекту: #2711558

Про проект