I'm making a script where the User makes a list and the same is sought in some text files and returns the results in a .txt only encounter the following problems:
The list is organized as follows on the interface:
Item1
item2
Item3
and is output as follows in the text file:
item1|item2|item3
First problem:
If the file from the beginning have a blank line:
item1
item2
item3
the output is with a "|" more and because the research problem:
item1||item2||item3
Second problem:
If the start/end have a blank line:
item1
item2
item3
the output is also in trouble at the time of search:
|item1|item2|item3|
Note: There may be several blank lines between the beginning, middle and end.
Note 2: The script goes inside a .hta, if necessary the code .hta will be at the end of post.
Note 3: The solution may be either batch, an external program or even vbs.
Option Explicit
Window.resizeTo 373,610
Const csFSpec = "List.ini"
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Sub Window_OnLoad()
If goFS.FileExists(csFSpec) Then
document.all.DataArea.value = goFS.OpenTextFile(csFSpec).ReadAll()
document.all.DataArea.value = Replace(document.all.DataArea.value,"|", vbcrlf)
Else
self.close
End If
If document.all.DataArea.value =vbcrlf Then
document.all.DataArea.value =""
Else
End If
End Sub
Sub SaveFile()
If document.all.DataArea.value = "" Then
document.all.DataArea.value =vbcrlf
goFS.CreateTextFile(csFSpec).Write document.all.DataArea.value
self.close
Else
document.all.DataArea.value = Replace(document.all.DataArea.value, "\", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "/", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, ":", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "*", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "?", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, """", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "<", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, ">", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "|", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "&", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "!", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value,vbcrlf,"|")
goFS.CreateTextFile(csFSpec).Write document.all.DataArea.value
self.close
End if
End Sub
Sub QuitEdit()
self.close
End Sub
Sub Redefine()
document.all.DataArea.value ="Item1" & vbcrlf & "Item2" & vbcrlf & "Item3"
End Sub
Sub Clean()
document.all.DataArea.value = ""
End Sub
Full Code:
<html>
<head>
<title>List</title>
<HTA:Application
Border= "thin"
Application="/md/input"
Scoll="NO"
Singleinstance="Yes"
SysMenu=NO
Icon="%Windir%\System32\wscript.exe">
ShowInTaskbar="Yes"
Caption="Yes">
<script type="text/vbscript">
Option Explicit
Window.resizeTo 373,610
Const csFSpec = "List.ini"
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Sub Window_OnLoad()
If goFS.FileExists(csFSpec) Then
document.all.DataArea.value = goFS.OpenTextFile(csFSpec).ReadAll()
document.all.DataArea.value = Replace(document.all.DataArea.value,"|", vbcrlf)
Else
self.close
End If
If document.all.DataArea.value =vbcrlf Then
document.all.DataArea.value =""
Else
End If
End Sub
Sub SaveFile()
If document.all.DataArea.value = "" Then
document.all.DataArea.value =vbcrlf
goFS.CreateTextFile(csFSpec).Write document.all.DataArea.value
self.close
Else
document.all.DataArea.value = Replace(document.all.DataArea.value, "\", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "/", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, ":", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "*", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "?", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, """", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "<", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, ">", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "|", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "&", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value, "!", "_")
document.all.DataArea.value = Replace(document.all.DataArea.value,vbcrlf,"|")
goFS.CreateTextFile(csFSpec).Write document.all.DataArea.value
self.close
End if
End Sub
Sub QuitEdit()
self.close
End Sub
Sub Redefine()
document.all.DataArea.value ="Item1" & vbcrlf & "Item2" & vbcrlf & "Item3"
End Sub
Sub Clean()
document.all.DataArea.value = ""
End Sub
</script>
</head>
<body style="overflow:hidden" bgColor="#000080"></body>
<caption></caption><hr></hr>
<font color="#FFFFFF" Times New Roman" size="13"><center><B>List</b></center></font>
<caption></caption><hr></hr>
<TR><td>
<input style="background-color:#F0F0F0; color: #000000; border: 2px transparent; float: left;" type="BUTTON" value="Clean" class="btn" id="btna" onclick="Clean" onmouseover="btna.style.background = '#808080'" onmouseout="btna.style.background = '#F0F0F0'">
<input style="background-color:#F0F0F0; color: #000000; border: 2px transparent; float: right;" type="BUTTON" value="Redefine" class="btn" id="btnb" onclick="Redefine" onmouseover="btnb.style.background = '#808080'" onmouseout="btnb.style.background = '#F0F0F0'">
</TR></td>
<Table border="3" style="width:100%; text-align: center" BORDERCOLOR=#F0F0F0>
<TR><td>
<form>
<textarea name="DataArea" rows="23" cols=37></textarea> </Table>
<TR><td>
<p>
<div align="right"><input style="background-color:#F0F0F0; color: #000000; border: 2px transparent" type="BUTTON" value=" OK " class="btn" id="btnc" onclick="SaveFile" onmouseover="btnc.style.background = '#808080'" onmouseout="btnc.style.background = '#F0F0F0'">
<input style="background-color:#F0F0F0; color: #000000; border: 2px transparent" type="BUTTON" value="Cancel" class="btn" id="btnd" onclick="QuitEdit" onmouseover="btnd.style.background = '#808080'" onmouseout="btnd.style.background = '#F0F0F0'">
</div>
</td></TR>
</form>
</body>
</html>
From Filter at https://skydrive.live.com/redir?resid=E2F0CE17A268A4FA!121 a set of 19 sample programs in one file for working with files. It has two sample programs, 1 for lopping off blank lines top and bottom, and another one for all blank lines. Filter has a batch file that makes calling vbs scripts easy.
TrimLine
filter trimline {top|end|both}
filter tl {t|e|b}
Trims blank lines from top and bottom of files.
top - removes blank lines from top of file.
end - removes blank lines from end of file.
both - removes blank lines from top and end of file.
Example
Fixes win.ini, not that it needs fixing, and sends it to the screen
filter trimline both < "%systemroot%\win.ini"
Script
Sub TrimLines
Set Arg = WScript.Arguments
set WshShell = createObject("Wscript.Shell")
Set Inp = WScript.Stdin
Set Outp = Wscript.Stdout
If LCase(Arg(1)) = "top" or LCase(Arg(1)) = "t" then
Flags = 0
Do Until Inp.AtEndOfStream
Line=Inp.readline
If Line <> "" then Flags = 1
If Flags = 1 then outp.writeline Line
Loop
ElseIf LCase(Arg(1)) = "e" or LCase(Arg(1)) = "end" then
PendingLines = ""
Do Until Inp.AtEndOfStream
Line=Inp.readline
If Line <> "" then
outp.writeline PendingLines & Line
PendingLines = ""
Else
PendingLines=PendingLines & vbcrlf
End If
Loop
ElseIf LCase(Arg(1)) = "b" or LCase(Arg(1)) = "both" then
Flags = 0
Do Until Inp.AtEndOfStream
Line=Inp.readline
If Line <> "" then Flags = 1
If Flags = 1 then
If Line <> "" then
outp.writeline PendingLines & Line
PendingLines = ""
Else
PendingLines=PendingLines & vbcrlf
End If
End If
Loop
End If
End Sub
BlankLine
filter blankline {e|a}
Trims all empty and/or blank lines from a file.
e - removes blank lines from a file.
a - removes blank lines and lines only composed of space or tab from a file.
Example
Fixes win.ini, not that it needs fixing, and sends it to the screen
filter blankline a < "%systemroot%\win.ini"
Script
Sub BlankLine
Set Arg = WScript.Arguments
set WshShell = createObject("Wscript.Shell")
Set Inp = WScript.Stdin
Set Outp = Wscript.Stdout
Set RegEx = New RegExp
RegEx.Pattern = "^\s+$"
If LCase(Arg(1)) = "e" then
Do Until Inp.AtEndOfStream
Line=Inp.ReadLine
If Len(Line) <> 0 Then
OutP.WriteLine Line
End If
Loop
ElseIf Lcase(Arg(1)) = "a" then
Do Until Inp.AtEndOfStream
Line=Inp.ReadLine
If Len(Line) <> 0 Then
If RegEx.Test(Line) = False then
OutP.WriteLine Line
End If
End If
Loop
End If
End Sub
Also you could use VBS replace command.
A = Replace("blah||blah", "||", "|")
Related
Hello can someone please tell me what could be the problem in my calendar. So let me explain whats happening. So first im trying to make a scheduler application and im using a WPF scheduler in VB, so to begin with, the tab of a calendar needs to display 3 items (Subject, Professor Name, Courses) so what i need to do is to choose a room first and then drag a subject name from the listbox (like this Sample1) and then next i need to drag a professors name (Sample2) and then heres where the problems starts
So it already displays two items (Subject and Professor) now i need to drag an item from Course listbox, but the problem is whenever I put a course to the tab of a calendar, it becomes like this instead
So the goal here is to show 3 dragged items but instead, it only shows 2 and the course is overwriting the name of the subject. Please help me, thank you! If you want to see the whole codes, heres the link https://drive.google.com/file/d/1fWKisPr9qDh54B4EMdwWJbY3KFgi_xfc/view?usp=sharing
Heres the code of where you can drag the items
'Dragging Data to Calendar
Sub Add_list_item(ByVal list As String)
Delay.Delay(1)
Dim count = 0
For Each item As CalendarItem In Calendar1.GetSelectedItems()
count += 1
If count > 1 Then
Return
Else
Dim get_item_end_time As DateTime = item.EndDate.AddHours(2)
get_item_end_time = get_item_end_time.AddMinutes(30)
Dim item_start_time = item.StartDate
Dim item_end_time = get_item_end_time
Dim item_tooltip = item.StartDate.ToString()
Dim start_time = item.StartDate.ToString("HH:mm tt")
Dim end_time = item.EndDate.ToString("HH:mm tt")
Dim dat_start As Date = item_tooltip
Dim ci As CultureInfo = CultureInfo.CreateSpecificCulture("en-US")
Dim dtfi As DateTimeFormatInfo = ci.DateTimeFormat
dtfi.AbbreviatedDayNames = {"Sun", "1", "2", "3", "4",
"5", "6"}
Dim output_start As String = String.Format(ci, "{0:ddd}", dat_start.AddDays(0))
Dim item_text = CStr(item.Text)
Dim parts As String() = item_text.Split(New String() {Environment.NewLine},
StringSplitOptions.None)
Dim get_item_total_hours = (item.EndDate - item.StartDate).TotalHours
Dim get_start_time As DateTime
Dim get_end_time As DateTime
If get_item_total_hours = 1 Then
get_start_time = item.StartDate.AddMinutes(-30)
get_end_time = item.EndDate.AddMinutes(30)
ElseIf get_item_total_hours = 1.5 Then
get_start_time = item.StartDate.AddHours(-1)
get_end_time = item.EndDate.AddHours(1)
ElseIf get_item_total_hours = 2 Then
get_start_time = item.StartDate.AddHours(-1).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(1).AddMinutes(30)
ElseIf get_item_total_hours = 2.5 Then
get_start_time = item.StartDate.AddHours(-2)
get_end_time = item.EndDate.AddHours(2)
ElseIf get_item_total_hours = 3 Then
get_start_time = item.StartDate.AddHours(-2).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(2).AddMinutes(30)
ElseIf get_item_total_hours = 3.5 Then
get_start_time = item.StartDate.AddHours(-3)
get_end_time = item.EndDate.AddHours(3)
ElseIf get_item_total_hours = 4 Then
get_start_time = item.StartDate.AddHours(-3).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(3).AddMinutes(30)
ElseIf get_item_total_hours = 4.5 Then
get_start_time = item.StartDate.AddHours(-4)
get_end_time = item.EndDate.AddHours(4)
ElseIf get_item_total_hours = 5 Then
get_start_time = item.StartDate.AddHours(-4).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(4).AddMinutes(30)
ElseIf get_item_total_hours = 5.5 Then
get_start_time = item.StartDate.AddHours(-5)
get_end_time = item.EndDate.AddHours(5)
ElseIf get_item_total_hours = 6 Then
get_start_time = item.StartDate.AddHours(-5).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(5).AddMinutes(30)
End If
If (ListBox1_Instructor.Items.Contains(list) = True) Then
Call Check_if_instructor(list)
End If
If parts.Count >= 3 Then
If (instructor_name = True) Then
Call Get_instructor_code(instructor_gender + list)
Call Get_course_name(corSec_id)
Call checkInstructorSchedule(start_time, end_time, output_start, instructor_id)
If (instructor_name = True) Then
If instructor_gender = "Male" Then
instructor_gender = "Mr. "
Else
instructor_gender = "Ms. "
End If
If item.Text <> "" Then
item.Text = parts(0) + vbNewLine + vbNewLine + instructor_gender + list
item.ApplyColor(Color.RoyalBlue)
End If
instructor_name = False
End If
Else
item.ApplyColor(Color.RoyalBlue)
item.Text = list + vbNewLine + vbNewLine + parts(2) + vbNewLine + vbNewLine
End If
ElseIf parts.Count = 1 Then
If (instructor_name = True) Then
Call Get_instructor_code(instructor_gender + list)
Call Get_course_name(corSec_id)
Call checkInstructorSchedule(start_time, end_time, output_start, instructor_id)
If (instructor_name = True) Then
If instructor_gender = "Male" Then
instructor_gender = "Mr. "
Else
instructor_gender = "Ms. "
End If
If item.Text <> "" Then
item.Text = parts(0) + vbNewLine + vbNewLine + instructor_gender + list
item.ApplyColor(Color.RoyalBlue)
End If
instructor_name = False
End If
Else
item.ApplyColor(Color.RoyalBlue)
item.Text = list + vbNewLine + vbNewLine + parts(parts.Count - 1) + vbNewLine + vbNewLine
End If
End If
Calendar1.Invalidate(item)
End If
Next
End Sub
I'm trying to add a couple of simple macros to a file that is a shared excel binary workbook. The problem whenever the file is unshared the macro does not work anymore. The code is as following:
Sub uploadMain()
Dim xlsFile As String
Dim wbResults As Workbook
Dim wbmCall As Workbook
Dim agmtCdCell As Range
Dim amtCldCell As Range
Dim srchRange As Integer
Dim callClmn As Integer
Dim srchString As String
Dim callAmt As String
Dim notFound As String
Dim lastRowNo As Long
Dim srchRowNo As Long
Dim srcRowNo As Long
Dim customView As Boolean
Dim amntReplaced As Boolean
Dim asset_column As Integer
Dim typ
Dim quantity_column As Integer
Dim quantity As Variant
Dim unique_identifier As Integer
Dim lastrow_updated As Integer
Dim lastrow_preupload As Integer
Dim wiersz
Dim asset As String
Dim state As String
Dim old_row As Integer
Dim amp As String
Dim loaded
Dim direction_column As Integer
Dim delivery_type As String
Sheets("Calls").Select
ThisWorkbook.Save
customView = False
amntReplaced = False
Application.ScreenUpdating = False
Set wbmCall = ThisWorkbook
asset_column = Cells.Find(What:="Asset", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
quantity_column = Cells.Find(What:="Quantity", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
srchRange = Cells.Find(What:="Agmt Code", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
direction_column = Cells.Find(What:="Direction", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
xlsFile = Application.GetOpenFilename("Excel Workbooks (*.xls; *.xlsx),*.xls;*.xslx", , "Select Acadia extract to import.", , False)
If xlsFile = "False" Then Exit Sub
Set wbResults = Workbooks.Open(Filename:=xlsFile, UpdateLinks:=0)
' call amtcalled removed
Dim relocList() As Variant
Dim lngPosition As Integer
Dim startingRow As Range
Dim i As Long
Dim temporary_row As Integer
wbmCall.Activate
Dim b As Integer
Sheets("AcadiaFeeds").Select
Dim amp_array()
If Range("J65536").End(xlUp).Row > 2 Then
Cells(Range("J65536").End(xlUp).Row, 10).Select 'last row
lastrow_preupload = Range("J65536").End(xlUp).Row
amp_array = Range(Selection, Selection.End(xlUp))
End If
wbResults.Activate
'________________
For i = 2 To lastrow_preupload
If Range("Z" & i).Value = "Deliver" Then
ActiveSheet.Range("E" & i).Select
Selection.Replace What:="GROSS", Replacement:="OTM", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Else
ActiveSheet.Range("E" & i).Select
Selection.Replace What:="GROSS", Replacement:="ITM", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End If
Next i
'_______________________
relocList = Array("Margin Call Amp ID", "Delivery Type", "Amp ID", "Call Type", "Business State", "Valuation Date", "Total Call Amount", "Our Unique Agreement Identifier", "Quantity", "FX Currency", "Security Id", "Type")
Stop
For lngPosition = LBound(relocList) To UBound(relocList)
Set startingRow = ActiveSheet.Rows(1).Find(What:=relocList(lngPosition), After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not startingRow Is Nothing Then
Columns(startingRow.Column).Select
Selection.Cut
Columns(1).Select
Selection.Insert Shift:=xlToRight
End If
Next lngPosition
Columns(13).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
Dim nextone As String
j = 1
i = 2
Do Until i = Range("A65000").End(xlUp).offset(1, 0).Row
If Cells(i, 8).Value = "Partial Disputed" Then
Rows(i).Delete
Else
i = i + 1
End If
If Cells(i, 11).Value = "Deliver" Then Cells(i, 11).Value = "Pledge"
If Cells(i, 1).Value = "PLEDGE" Then
temporary_row = WorksheetFunction.Match(Cells(i, 12), Range("J:J"), 0)
Cells(i, 5) = Cells(temporary_row, 5)
Cells(i, 8) = Cells(temporary_row, 8)
End If
Loop
Dim As String
i = 1
'remove blanks
=======================================================================================================================================================
lastRowNo = Range("A65000").End(xlUp).Row
wbmCall.Activate
Sheets("AcadiaFeeds").Select
If ActiveSheet.FilterMode = True Then ActiveSheet.FilterMode = False 'gdyby komus wpadl do lepetyny glupi pomysl dodawania filtra w Acadia Feeds
srchRowNo = Range("A65000").End(xlUp).Row + 5
If srchRowNo < 10 Then
srchRowNo = 10
lastrow_preupload = 10
End If
Range("L" & srchRowNo).Value = "Uploaded " & Format(Now, "mmm dd, yyyy hh:mm:ss") & " by " & LCase(Environ("USERNAME"))
srcRowNo = 1
i = 1
Do Until i > lastRowNo
Range("A" & srchRowNo & ":K" & srchRowNo).Value = wbResults.Sheets(1).Range("A" & srcRowNo & ":K" & srcRowNo).Value
srchRowNo = srchRowNo + 1
srcRowNo = srcRowNo + 1
i = i + 1
Loop
wbResults.Close SaveChanges:=False
Set wbResults = Nothing
wbmCall.Activate
Set wbmCall = Nothing
ActiveWorkbook.Sheets("Calls").Select
If ActiveSheet.AutoFilterMode = True Then
customView = True
Application.EnableEvents = False
ActiveWorkbook.CustomViews.Add ViewName:="doAcadii", RowColSettings:=True
ActiveSheet.AutoFilterMode = False
Application.EnableEvents = True
End If
ActiveWorkbook.Sheets("AcadiaFeeds").Select
callClmn = 5 'Our Unique Agreement Identifier na sztywno
cTypeClmn = 9 'call type na sztywno w kolumnie 5tej
=======================================================================================================================================================
backAtLoop:
srchRowNo = lastrow_preupload
lastrow_updated = Range("A65000").End(xlUp).Row
Do Until srchRowNo = lastrow_updated + 1
ActiveWorkbook.Sheets("AcadiaFeeds").Select
srchRowNo = srchRowNo + 1
amp = Cells(srchRowNo, callClmn + 5).Value ' amp ID
srchString = Cells(srchRowNo, callClmn).Value 'od dolu bierze unique identifier
callAmt = Cells(srchRowNo, callClmn + 1).Value 'amt called
cType = Cells(srchRowNo, cTypeClmn).Value 'call type
quantity = Cells(srchRowNo, callClmn - 1).Value 'ilosc papierow
state = Cells(srchRowNo, callClmn + 3).Value 'business state pledge accepted
delivery_type = Cells(srchRowNo, callClmn + 6)
typ = Cells(srchRowNo, 1).Value 'margin_call lub pledge
If Cells(srchRowNo, callClmn - 3).Value <> "CASH" Then
asset = Cells(srchRowNo, callClmn - 3).Value ' aktywo
Else:
asset = Cells(srchRowNo, callClmn - 2).Value
End If
Sheets("Calls").Select
Set foundmatchx = Columns(srchRange).Find(What:=srchString, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If typ = "MARGIN_CALL" Then
If Application.WorksheetFunction.CountIf(Columns(srchRange), srchString) = 0 Then 'sprawdza dany agreement jest w mcalls table
Sheets("AcadiaFeeds").Select
notFound = notFound & "; " & srchString
Range("A" & srchRowNo & ":I" & srchRowNo).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K" & srchRowNo).Value = "Not Found"
ElseIf Application.WorksheetFunction.CountIf(Columns(srchRange), srchString) <> 0 Then
'howMany = Application.WorksheetFunction.CountIf(Columns(srchRange), srchString)
foundmatchx.offset(0, 3).Activate ' aktywuje offset AMT called
If ActiveCell.offset(0, 11) = "Initial" And cType = "Initial" Then 'idk nor care
'nowt to do here
ElseIf cType = "Initial" And Right(srchString, 4) <> "FBCO" Then
ActiveWorkbook.Sheets("AcadiaFeeds").Select 'acadia feeds
Range("A" & srchRowNo & ":E" & srchRowNo).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("F" & srchRowNo).Value = "IM call not found"
GoTo nexxtSrchRowNo
ElseIf cType = "Initial" And Right(srchString, 4) = "FBCO" Then
'nowt to do here
Else
Columns(srchRange).FindNext(foundmatchx).offset(0, 3).Activate
End If
Range("J" & srchRowNo).Value = "Already Loaded", Range("A" & srchRowNo & ":I" & srchRowNo).Select
If ActiveCell.Value = callAmt Then
ActiveWorkbook.Sheets("AcadiaFeeds").Select 'acadia feeds
With ActiveWorkbook.Sheets("AcadiaFeeds").Range("A" & srchRowNo & ":I" & srchRowNo).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K" & srchRowNo).Value = "Already Loaded"
ElseIf ActiveCell.Value <> "" And ActiveCell.Value <> callAmt Then
ActiveWorkbook.Sheets("AcadiaFeeds").Select 'acadia feeds
Range("A" & srchRowNo & ":E" & srchRowNo).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K" & srchRowNo).Value = "Loaded w/ different amt - please investigate"
amntReplaced = True
Else
ActiveCell.Value = callAmt
ActiveCell.offset(0, 20).Value = "loaded from AcadiaFeeds sheet row# " & srchRowNo
End If
Else
MsgBox "Something unexpected happend"
End If
nexxtSrchRowNo:
End If
ActiveWorkbook.Sheets("AcadiaFeeds").Select
If typ = "PLEDGE" Then
Sheets("Calls").Select 'calls
wiersz = foundmatchx.Row
If IsVarArrayEmpty(amp_array) = False Then
j = 1
loaded = "not_loaded"
For j = 1 To UBound(amp_array)
If amp_array(j, 1) = amp Then
loaded = "already_loaded"
j = UBound(amp_array)
End If
Next
Else: loaded = "not_loaded"
End If
Select Case loaded
Case "already_loaded"
If state = "Pledge Accepted" Then
If IsEmpty(Cells(wiersz, quantity_column)) = False And quantity <> Cells(wiersz, quantity_column) Then
Application.Union(Range(Cells(wiersz + 1, srchRange - 2), Cells(wiersz + 1, srchRange - 1)), Range(Cells(wiersz + 1, srchRange + 1), Cells(wiersz + 1, srchRange + 2))).Style = "Good"
Else:
Application.Union(Range(Cells(wiersz, srchRange - 2), Cells(wiersz, srchRange - 1)), Range(Cells(wiersz, srchRange + 1), Cells(wiersz, srchRange + 2))).Style = "Good"
End If
End If
Case "not_loaded"
If delivery_type = Cells(wiersz, direction_column) And IsEmpty(Cells(wiersz, quantity_column)) = True Then
If state = "Pledge Accepted" Then
Application.Union(Range(Cells(wiersz, srchRange - 2), Cells(wiersz, srchRange - 1)), Range(Cells(wiersz, srchRange + 1), Cells(wiersz, srchRange + 2))).Style = "Good"
End If
Cells(wiersz, quantity_column) = quantity
Cells(wiersz, asset_column) = asset
ElseIf delivery_type = Cells(wiersz, direction_column) And IsEmpty(Cells(wiersz, quantity_column)) = False Then
Cells(wiersz, quantity_column).Select
Call MainModule.insertRow
Cells(wiersz + 1, quantity_column) = quantity
Cells(wiersz + 1, asset_column) = asset
If state = "Pledge Accepted" Then
Application.Union(Range(Cells(wiersz + 1, srchRange - 2), Cells(wiersz + 1, srchRange - 1)), Range(Cells(wiersz + 1, srchRange + 1), Cells(wiersz + 1, srchRange + 2))).Style = "Good"
End If
ElseIf delivery_type <> Cells(wiersz, direction_column) Then
howMany = Application.WorksheetFunction.CountIf(Columns(srchRange), srchString)
i = 1
For i = 1 To howMany
Set foundmatchx = Columns(srchRange).FindNext(foundmatchx)
'daje find dla danego agreeementu
temporary_row = foundmatchx.Row
If delivery_type = Cells(temporary_row, direction_column) And IsEmpty(Cells(temporary_row, quantity_column)) = True Then
'1_17 change
If state = "Pledge Accepted" Then
Application.Union(Range(Cells(temporary_row, srchRange - 2), Cells(temporary_row, srchRange - 1)), Range(Cells(temporary_row, srchRange + 1), Cells(temporary_row, srchRange + 2))).Style = "Good"
End If
Cells(temporary_row, quantity_column) = quantity
Cells(temporary_row, asset_column) = asset
i = howMany
End If
Next
End If
End Select
End If
Loop
ActiveWorkbook.Sheets("Calls").Select
'aplikuje filtr spowrotem
If customView = True Then
Application.EnableEvents = False
With ActiveWorkbook.CustomViews("doAcadii")
.Show
.Delete
End With
Application.EnableEvents = True
End If
Application.ScreenUpdating = True
'ponizsze IF dodane 07/30
If amntReplaced = True Then
MsgBox "Acadia extract uploaded, but some calls were loaded with different call amounts." & vbCrLf & _
"Please investigate for issues before saving this spreadsheet."
Else
MsgBox "Acadia extract uploaded!"
End If
End Sub
Sub amtsCalled()
Application.ScreenUpdating = False
Dim relocList() As Variant
Dim lngPosition As Integer
Dim startingRow As Range
Dim i As Long
Dim temporary_row As Integer
wbmCall.Activate
Sheets("AcadiaFeeds").Select
Dim amp_array()
Cells(Range("J65536").End(xlUp).Row, 10).Select 'last row
MsgBox (Cells(Range("J65536").End(xlUp).Row, 10))
amp_array = Range(Selection, Selection.End(xlUp))
wbResults.Activate
relocList = Array("Margin Call Amp ID", "Amp ID", "Call Type", "Business State", "Valuation Date", "Total Call Amount", "Our Unique Agreement Identifier", "Quantity", "FX Currency", "Security Id", "Type")
Stop
For lngPosition = LBound(relocList) To UBound(relocList)
Set startingRow = ActiveSheet.Rows(1).Find(What:=relocList(lngPosition), After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not startingRow Is Nothing Then
Columns(startingRow.Column).Select
Selection.Cut
Columns(1).Select
Selection.Insert Shift:=xlToRight
End If
Next lngPosition
Columns(12).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
Dim nextone As String
i = 2
Do Until i = Range("A65000").End(xlUp).offset(1, 0).Row
For j = 1 To UBound(amp_array)
If Cells(i, 10).Value = amp_array(j, 1) Then GoTo nextone
Next
If Cells(i, 8).Value = "Partial Disputed" Then
Rows(i).Delete
Else
i = i + 1
End If
If Cells(i, 1).Value = "PLEDGE" Then
temporary_row = WorksheetFunction.Match(Cells(i, 11), Range("J:J"), 0)
Cells(i, 5) = Cells(temporary_row, 5)
End If
nextone:
Loop
'remove blanks
On Error GoTo 0
Exit Sub
Application.ScreenUpdating = True
End Sub
Sub ss()
Application.ScreenUpdating = True
End Sub
Function IsVarArrayEmpty(anArray As Variant)
Dim i As Integer
On Error Resume Next
i = UBound(anArray, 1)
If Err.Number = 0 Then
IsVarArrayEmpty = False
Else
IsVarArrayEmpty = True
End If
End Function
Some of the lines are in Polish, is this causing the issue with uploading new macros and working when it's unshared?
It looks like this is by design:
"Once you share a workbook, any Visual Basic project it contains is no longer accessible. Excel can’t deal with multiple users editing the same macros, so it simply prevents changes to those macros. You can’t record new macros, either. However, you can run macros from shared workbooks."
Ref: https://www.oreilly.com/library/view/programming-excel-with/0596007663/ch08s03.html
I have website which is working on my one server now I have migrated to another server changed the connection string. But one weird thing is some pages working fine but some page show me " page can not be displayed error message. I am new in VBscript Can anyone help me what am missing"
Below is the code of page which is not working on new server but working on old server
Microsoft VBScript runtime error '800a01a8' : object required
<%#LANGUAGE="VBSCRIPT" CODEPAGE="1252"%>
<% if session("MM_Username") = "" or isnull(session("MM_Username")) then
response.redirect("/login.asp")
end if
%>
<%
Dim MM_editAction
Dim MM_abortEdit
Dim MM_editQuery
Dim MM_editCmd
Dim MM_editConnection
Dim MM_editTable
Dim MM_editRedirectUrl
Dim MM_editColumn
Dim MM_recordId
Dim MM_fieldsStr
Dim MM_columnsStr
Dim MM_fields
Dim MM_columns
Dim MM_typeArray
Dim MM_formVal
Dim MM_delim
Dim MM_altVal
Dim MM_emptyVal
Dim MM_i
MM_editAction = CStr(Request.ServerVariables("SCRIPT_NAME"))
If (Request.QueryString <> "") Then
MM_editAction = MM_editAction & "?" & Server.HTMLEncode(Request.QueryString)
End If
' boolean to abort record edit
MM_abortEdit = false
' query string to execute
MM_editQuery = ""
%>
<%
' *** Update Record: set variables
If (CStr(Request("MM_update")) = "form1" And CStr(Request("MM_recordId")) <> "") Then
MM_editConnection = MM_v3_STRING
MM_editTable = "dbo.custMessage"
MM_editColumn = "id"
MM_recordId = "" + Request.Form("MM_recordId") + ""
MM_editRedirectUrl = "Change.asp"
MM_fieldsStr = "textarea|value"
MM_columnsStr = "message|',none,''"
' create the MM_fields and MM_columns arrays
MM_fields = Split(MM_fieldsStr, "|")
MM_columns = Split(MM_columnsStr, "|")
' set the form values
For MM_i = LBound(MM_fields) To UBound(MM_fields) Step 2
MM_fields(MM_i+1) = CStr(Request.Form(MM_fields(MM_i)))
Next
' append the query string to the redirect URL
If (MM_editRedirectUrl <> "" And Request.QueryString <> "") Then
If (InStr(1, MM_editRedirectUrl, "?", vbTextCompare) = 0 And Request.QueryString <> "") Then
MM_editRedirectUrl = MM_editRedirectUrl & "?" & Request.QueryString
Else
MM_editRedirectUrl = MM_editRedirectUrl & "&" & Request.QueryString
End If
End If
End If
%>
<%
' *** Update Record: construct a sql update statement and execute it
If (CStr(Request("MM_update")) <> "" And CStr(Request("MM_recordId")) <> "") Then
' create the sql update statement
MM_editQuery = "update " & MM_editTable & " set "
For MM_i = LBound(MM_fields) To UBound(MM_fields) Step 2
MM_formVal = MM_fields(MM_i+1)
MM_typeArray = Split(MM_columns(MM_i+1),",")
MM_delim = MM_typeArray(0)
If (MM_delim = "none") Then MM_delim = ""
MM_altVal = MM_typeArray(1)
If (MM_altVal = "none") Then MM_altVal = ""
MM_emptyVal = MM_typeArray(2)
If (MM_emptyVal = "none") Then MM_emptyVal = ""
If (MM_formVal = "") Then
MM_formVal = MM_emptyVal
Else
If (MM_altVal <> "") Then
MM_formVal = MM_altVal
ElseIf (MM_delim = "'") Then ' escape quotes
MM_formVal = "'" & Replace(MM_formVal,"'","''") & "'"
Else
MM_formVal = MM_delim + MM_formVal + MM_delim
End If
End If
If (MM_i <> LBound(MM_fields)) Then
MM_editQuery = MM_editQuery & ","
End If
MM_editQuery = MM_editQuery & MM_columns(MM_i) & " = " & MM_formVal
Next
MM_editQuery = MM_editQuery & " where " & MM_editColumn & " = " & MM_recordId
If (Not MM_abortEdit) Then
' execute the update
Set MM_editCmd = Server.CreateObject("ADODB.Command")
MM_editCmd.ActiveConnection = MM_editConnection
MM_editCmd.CommandText = MM_editQuery
MM_editCmd.Execute
MM_editCmd.ActiveConnection.Close
If (MM_editRedirectUrl <> "") Then
Response.Redirect(MM_editRedirectUrl)
End If
End If
End If
%>
<%
Dim change__MMColParam
change__MMColParam = "1"
If (Request("MM_EmptyValue") <> "") Then
change__MMColParam = Request("MM_EmptyValue")
End If
%>
<%
Dim change
Dim change_numRows
Set change = Server.CreateObject("ADODB.Recordset")
change.ActiveConnection = MM_v3_STRING
change.Source = "SELECT * FROM dbo.custMessage WHERE id = " + Replace(change__MMColParam, "'", "''") + ""
change.CursorType = 0
change.CursorLocation = 2
change.LockType = 1
change.Open()
change_numRows = 0
%>
<%
'setup database connection
dim conn
set conn = server.CreateObject ("ADODB.Connection")
conn.ConnectionString = "Provider=SQLOLEDB;User ID=***;Password=***;Initial Catalog=heart_Test;Data Source=****;"
conn.Open
%>
So here is the answer.
Start Internet Services Manager.
Click Default Web Site, and then click Properties.
Double-click ASP in the Features pane.
Expand Behavior.
Click Enable Parent Paths.
Click True for Enable Parent Paths.
Click Apply.
I dont know whether this is proper question or not but I am learning. I have a webpage which has some buttons on it
like japan,tokyo,india,UK, USA
and a folder which has images on it
YK08HJX_SYPTE_20140403170541594.jpg
YK08HJX_SYPTE_20140403170542194.jpg
1YK0BHJX_SYPTE1-PC_20140403170000670.jpg
. when user click s on any button on webpage it should change the sypte1-PC or SYPTE to that button text.
YK08HJX_japan_20140403170541594.jpg
YK08HJX_INDIA_20140403170542194.jpg
1YK0BHJX_UK_20140403170000670.jpg.
any help would be appreciated.
this was my code: but dont how to interact directly with webpage on button click or href. text.
Listing A: RenameFiles.vbs
Dim WshShell, FileManagement, BrowseDialogBox, SelectedFolder, OldString, NewString, FullPath, TheFolder, FileList
Dim File, ThisFile, TheString, AlreadyRenamed, TempName, FlagName, Success, FindFlag, NewName, Dummy
Set WshShell = WScript.CreateObject("WScript.Shell")
Set FileManagement = WScript.CreateObject ("Scripting.FileSystemObject")
Set BrowseDialogBox = WScript.CreateObject("Shell.Application")
Set SelectedFolder = BrowseDialogBox.BrowseForFolder(0, "Select the folder containing the files you want to rename.", &H0001)
If InStr(1, TypeName(SelectedFolder), "Folder") = 0 Then
WScript.Quit
Else
OldString = InputBox("Enter the characters in the filename that you want to replace","Rename Files")
If OldString = "" Then WScript.Quit
NewString = InputBox("Enter the characters that you want to replace them with","Rename Files")
‘If NewString = "" Then WScript.Quit
End If
FullPath = SelectedFolder.ParentFolder.ParseName(SelectedFolder.Title).Path
Set TheFolder = FileManagement.GetFolder(FullPath)
Set FileList = TheFolder.Files
Success = 0
For Each File In FileList
ThisFile = File.Name
TheString = InStr(ThisFile, OldString)
AlreadyRenamed = InStr(ThisFile, "%")
If (TheString <> 0) And (AlreadyRenamed = 0) Then
Success = 1
TempName = Replace(ThisFile, OldString, NewString)
FlagName = "%" + TempName
File.Name = FlagName
End If
Next
For Each File In FileList
ThisFile = File.Name
FindFlag = InStr(ThisFile, "%")
If FindFlag <> 0 Then
NewName = Replace(ThisFile, "%", "")
File.Name = NewName
End If
Next
If Success = 1 Then
Dummy = WshShell.Popup ("Rename Files operation complete!",5,"Rename Files",64)
Else
Dummy = WshShell.Popup ("Rename Files operation failed! Please repeat the operation.",0,"Rename Files",16)
End If
WScript.Quit
You mentioned you were having trouble interacting with the webpage or button click. So I'll help you with that portion. You can create a single button-click event that is fired whenever any of your buttons are clicked. That way you can keep your code in a single sub. Here's an example:
<html>
<body>
<script language="vbscript">
Sub DoClick(strText)
' strText will hold the name of the button that was clicked.
' Use it to rename your files.
End Sub
</script>
<input type="button" onclick="DoClick('Japan')" value="Japan" />
<input type="button" onclick="DoClick('USA')" value="USA" />
</body>
</html>
In a Classic ASP website and MSSQL database: When a search for data is completed the URL displays the ID of the results. eg sitename/Display_Results.asp?cboService=253&cboRegion=588. Where is the script or code that determines the return of the ID, is it in the page code or database stored procedures? I want to display the description of the Id in the URL.
<%# language="vbscript" codepage="1252"%>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<%
sRoot = ""`
Function alert(msg,where)
%>
alert('<%="Message = "&msg&"\nWhere = "&where%>') <% end function
fFunction Ceiling(byval n) Dim iTmp, bErr
on error resume next
n = cdbl(n)
if err then bErr = true
on error goto 0
if bErr then Err.Raise 5000, "Ceiling Function", _
"Input must be convertible to a sub-type of double"
f = Floor(n)
if f = n then
Ceiling = n
Exit Function
End If
Ceiling = cInt(f + 1)
End Function
%>
<html>
<head>
<!--#include file="includes/scripts/Includes.asp"-->
<%
Call WriteServiceMetaData(objConn, strConn)
%>
<script type="text/javascript" src="includes/scripts/javascript.js"></script>
<script type="text/javascript" src="includes/scripts/pngfix.mod.js"></script>
<script type="text/javascript" src="includes/scripts/swfobject.js"></script>
<script type="text/javascript" src="swfobject/swfobject.js"></script>
<script type="text/javascript">
function showborder(idnew,argsnew){
var idnew = idnew;
var argsnew = argsnew;
if(argsnew == "on"){
document.getElementById(idnew).style.border='2px solid #759fb9';
}
else{
document.getElementById(idnew).style.border='';
}
}
</script>
<script type="text/javascript">
function showpng(idnew,argsnew){
var idnew = idnew;
var argsnew = argsnew;
if(argsnew == "on"){
document.getElementById(idnew).style.visibility='';
}
else{
document.getElementById(idnew).style.visibility='hidden';
}
}
</script>
<link rel="stylesheet" type="text/css" href="<%=sRoot%>css/universal.css">
</head>
<%
Dim maxResults
Dim DRCountry_ID, Country_Variable
Dim DRCounty_ID, County_Variable
Dim DRLocation, Location_Variable
Dim DRType_ID, DRType_ID_Array, Type_Variable, cType_Variable
Dim End_request, LUXSQL
Dim Query, Query_Result
Dim Page_Num, HOTSQL, HOTOFFER, Text, DRTube_ID, DRPrice_Min, DRPrice_Max, Tube_Variable, DRPrice, Price_Variable
Dim lCityID, lCountyID, lCountryID
set objRS = objConn.execute ("General_Admin_List")
maxResults = objRS("Num_Results")
objRS.Close
set objRS = nothing
'on error resume next
'Page_Num= clng(Request.QueryString("Page_Num"))
'if err.number <> 0 then
'Page_Num = 0
'end if
'on error goto 0
if strcomp(Request.ServerVariables("REQUEST_METHOD"), "POST", 1) = 0 then
on error resume next
if len(trim(Request.Form("HotOffer"))) > 0 then
iHotOffer = 1
else
iHotOffer = 0
end if
on error resume next
'Turn off error handling
company = trim(request.Form("company"))
if company = "Enter Name" then
company = ""
end if
if err.number <> 0 then
'If there is an error then the requested input is not a number
company = "null"
end if
err.clear
'Turn error handling back on
on error goto 0
lCountyID = clng(trim(Request.Form("cboRegion")))
if err.number <> 0 then
lCountyID = 0
end if
err.clear
lCountryID = clng(trim(Request.Form("cboCountry")))
if err.number <> 0 then
lCountryID = 0
end if
err.clear
lFeatureID = clng(trim(Request.Form("cboFeature")))
if err.number <> 0 then
lFeatureID = 0
end if
err.clear
lServiceID = clng(Request.Form("cboService"))
if err.number <> 0 or lServiceID < 1 then
lServiceID = 0
else
session("SearchServiceID") = lServiceID
end if
err.clear
lCityID = clng(Request.Form("cboCity"))
if err.number <> 0 or lCityID < 1 then
lCityID = 0
end if
sTypes = trim(Request.Form("asfTypes"))
session("searchTypes") = sTypes
on error goto 0
else
on error resume next
'Turn off error handling
company = trim(request.QueryString("company"))
if company = "Enter Name" then
company = ""
end if
if err.number <> 0 then
'If there is an error then the requested input is not a number
company = "null"
end if
err.clear
'Turn error handling back on
on error goto 0
on error resume next
if len(trim(Request.QueryString("HotOffer"))) > 0 then
iHotOffer = 1
else
iHotOffer = 0
end if
lCountyID = clng(trim(Request.QueryString("cboRegion")))
if err.number <> 0 then
lCountyID = 0
end if
err.clear
lCountryID = clng(trim(Request.QueryString("cboCountry")))
if err.number <> 0 then
lCountryID = 0
end if
err.clear
lFeatureID = clng(trim(Request.QueryString("cboFeature")))
if err.number <> 0 then
lFeatureID = 0
end if
err.clear
lServiceID = clng(Request.QueryString("cboService"))
if err.number <> 0 or lServiceID < 1 then
lServiceID = 0
else
session("SearchServiceID") = lServiceID
end if
err.clear
if request.QueryString("asfFeatures") <> "" then
lFeatureID = clng(Request.QueryString("asfFeatures"))
if err.number <> 0 or lFeatureID < 1 then
lFeatureID = 0
end if
err.clear
end if
lCityID = clng(Request.QueryString("CityID"))
if err.number <> 0 or lCityID < 1 then
lCityID = 0
end if
sTypes = trim(Request.QueryString("asfTypes"))
'Response.Write(sTypes)
session("searchTypes") = sTypes
on error goto 0
end if
if lCityID = 0 then
sCity = trim(Request.QueryString("City"))
if len(sCity) = 0 then
lCityID = 0
else
set objRS = objConn.execute ("City_Lookup '" & Replace(sCity, "'", "''") & "'")
if objRS.EOF then
lCityID = 999999
else
lCityID = objRS("City_ID")
lCountyID = objRS("County_ID")
lCountryID = objRS("Country_ID")
end if
objRS.Close
set objRS = nothing
end if
end if
'This below was commented out, seems to do nothing
' Not using location finder just yet
dim sURL
sURL = "Select_Location.asp?location=" & Server.URLEncode(trim(Request.QueryString("SLocation"))) & "&Search=" & Request.QueryString("Search")
sURL = sURL & "&Service=" & lServiceID
sURL = sURL & "&Types=" & sTypes
DRLocation = replace(trim(Request.QueryString("SLocation")), "'", "''")
if len(DRLocation) > 0 then ' and lCountryID = 0 then
set objRS = Server.CreateObject("ADODB.Recordset")
objRS.CursorLocation = 3
objRS.Open "City_Lookup '" & DRLocation & "'," & lCountyID & ", " & lCountryID, objConn
if objRS.RecordCount > 1 then
objRS.Close
objConn.close
response.Redirect(sURL)
end if
if not objRS.eof then
lCityID = clng(objRS("City_ID"))
lCountyID = clng(objRS("County_ID"))
else
objRS.Close
objRS.Open "County_Lookup '" & DRLocation & "', " & lCountryID, objConn
if objRS.RecordCount > 1 then
objRS.Close
objConn.close
response.Redirect(sURL)
end if
if not objRS.eof then
lCountyID = clng(objRS("County_ID"))
else
objRS.Close
objConn.close
response.Redirect(sURL)
end if
end if
objRS.Close
set objRS = nothing
end if
'This above was commented out, seems to do nothing
dim lSearchID
lSearchID = 0
if len(sTypes) > 0 then
Application.Lock()
if Application("LSG_SearchID") = "" then
lSearchID = 1
else
lSearchID = clng(Application("LSG_SearchID")) + 1
end if
Application("LSG_SearchID") = lSearchID
Application.UnLock()
objConn.execute "Value_Splitter '" & sTypes & "', ',', " & lSearchID
end if
objConn.CursorLocation = adUseClient
set objComm = Server.CreateObject("ADODB.Command")
set objComm.ActiveConnection = objConn
objComm.CommandText = "Search"
objComm.CommandType = adCmdStoredProc
objComm.Parameters.Append objComm.CreateParameter ("#City_ID", adInteger, adParamInput)
objComm.Parameters.Append objComm.CreateParameter ("#County_ID", adInteger, adParamInput)
objComm.Parameters.Append objComm.CreateParameter ("#Country_ID", adInteger, adParamInput)
objComm.Parameters.Append objComm.CreateParameter ("#Service_ID", adInteger, adParamInput)
objComm.Parameters.Append objComm.CreateParameter ("#Search_ID", adInteger, adParamInput)
objComm.Parameters.Append objComm.CreateParameter ("#Feature_ID", adInteger, adParamInput)
objComm.Parameters.Append objComm.CreateParameter ("#Specialist_Area", adBoolean, adParamInput, , iHotOffer)
objComm.Parameters.Append objComm.CreateParameter ("#ResultCount", adInteger, adParamOutput)
objComm.Parameters.Append objComm.CreateParameter ("#Company", adVarchar, adParamInput, 255)
if lCountryID > 0 then
objComm.Parameters("#Country_ID") = lCountryID
end if
if lCountyID > 0 then
objComm.Parameters("#County_ID") = lCountyID
end if
if lCityID > 0 then
objComm.Parameters("#City_ID") = lCityID
end if
if lServiceID > 0 then
objComm.Parameters("#Service_ID") = lServiceID
end if
if lFeatureID > 0 then
objComm.Parameters("#Feature_ID") = lFeatureID
end if
if lSearchID > 0 then
objComm.Parameters("#Search_ID") = lSearchID
end if
if company = "null" then
objComm.Parameters("#Company") = null
else
objComm.Parameters("#Company") = company
end if
'Query = "Search " & paramCity & ", " & paramCounty & ", " & paramCountry
'end if
'response.End()
'Set Query_Result = Server.CreateObject("ADODB.Recordset")
'Response.Write("Query"&Query)
set Query_Result = objComm.Execute()
lResultCount = objComm.Parameters("#ResultCount").value
lSearchCity = lCityID
if lServiceID > 0 then
SELECT_SQL = "Service_Get "& lServiceID
Set SELECT_SQL_RESULT = Server.CreateObject("ADODB.Recordset")
SELECT_SQL_RESULT.Open SELECT_SQL, ObjConn
do while not SELECT_SQL_RESULT.eof
service = SELECT_SQL_RESULT("service")
service_description = SELECT_SQL_RESULT("Service_Description")
SELECT_SQL_RESULT.MoveNext
Loop
SELECT_SQL_RESULT.Close
end if
'Get city (set email location) from search and put into cookie
if Request.QueryString("CityID") > 0 Then
GetCity = "getCity "&Request.QueryString("CityID")
Set GetCity_Result = Server.CreateObject("ADODB.Recordset")
GetCity_Result.Open GetCity, ObjConn
if not GetCity_Result.eof then
emailCity = GetCity_Result("City")
end if
Response.Cookies("LSG")("Location") = emailCity
Response.Cookies("LSG").Expires= DateAdd("d", Date(), 365)
end if
%>
<%
Dim SELECT_SQL, SELECT_SQL_RESULT
Dim Top_PAGECONTENT_Title, Top_PAGECONTENT_Content
Dim Bottom_PAGECONTENT_Title, Bottom_PAGECONTENT_Content
Dim page_name, url,sPath
sPath=""
url = request.ServerVariables("URL")
page_name = right(url, len(url) - instrrev(url, "/"))
SELECT_SQL = "Page_Content_Get '"& page_name &"'"
Set SELECT_SQL_RESULT = Server.CreateObject("ADODB.Recordset")
SELECT_SQL_RESULT.Open SELECT_SQL, ObjConn
do while not SELECT_SQL_RESULT.eof
If SELECT_SQL_RESULT("Position") = "Page Top" then
Top_PAGECONTENT_Title = SELECT_SQL_RESULT("Title")
Top_PAGECONTENT_Content = SELECT_SQL_RESULT("Content")
Top_PAGECONTENT_Content = Replace(Top_PAGECONTENT_Content, vbcrlf, "<br>")
end if
SELECT_SQL_RESULT.MoveNext
Loop
SELECT_SQL_RESULT.Close
%>
<body>
<div class="SiteContainer">
<!--#include file="includes/content/banner_rotator.asp"-->
<div class="LeftSiteContainer">
<!--#include file="includes/content/hdg_left.asp"-->
<!--#include file="includes/content/hdg_Header2.asp"-->
<div class="indexMainContainer">
<div id="mainLeftContent">
<div class="MainContent">
<%
if service = "" then
service = "Boat and Yacht products and services"
end if
if emailcity = "" then
emailcity = "Boat Chandlers Guide"
end if
%>
<%If not Query_Result.EOF Then%>
<span style="color:#1A59CD;"><h1><%=service%></h1></span>
<span style="color:#1A59CD;"><h2><%=Service_Description%></h2></span>
<div style="color:#666666; float:left; padding-top:8px;">Your search returned <span style="color:#1A59CD; font-weight:bold;"><%=lResultCount%></span> result<%if lResultCount > 1 then response.write "s" end if%> for <!--<%=emailcity%> to--> <%=service%> </div>
<div style="clear:both;"> </div>
<!--<h2><%=emailcity%> search results for <%=service%></h2>-->
<% else %>
<div style="clear:both;"></div>
<span style="color:#1A59CD;"><h1><%=emailcity%> <%=service%></h1></span>
<div class="search_no_results">
<strong>Sorry, there are currently no <%=service%> featured on <%=emailcity%> at this time.</strong>
</div>
<% End If %>
<%If not Query_Result.EOF Then
numResults = maxResults 'The Number of Results to Display on each page
count = lResultCount
dim Number_array, Total_Pages
Number_Array = split(((count-1) / numResults),".")
Total_Pages = count \ numResults
if count mod numResults > 0 then
Total_Pages = Total_Pages + 1
end if
%>
<%end if
If Query_Result.EOF Then%>
<div class="search_no_results">
<strong>Sorry, no results were found that match your search criteria.</strong>
</div>
<% End If
Dim count, strt, endd, numResults, tr_count
tr_count = 0
'-----------------------------------------------'
' Set the Number of the first record to display '
'-----------------------------------------------'
if not Query_Result.eof then
strt = cint(Request.queryString("results"))
if (strt = null) OR (strt <= 0) then
strt = 1
end if
endd = strt + numResults-1
if numresults = 1 then
Page_Num = strt
else
Page_Num = strt \ numresults
Page_Num = Page_Num + 1
end if
end if
count = 1
PageEnd = Page_Num * numResults
PageStart = PageEnd - 20
if PageEnd > lResultCount then
pageEnd = lResultCount
end if
if request.QueryString("st") = "" then
CurrentPageNumber = 1
else
CurrentPageNumber = request.QueryString("st")
end if
'How many on first number
FirstNum = numResults * (CurrentPagenumber - 1) - (numResults -1)
if clng(CurrentPageNumber) < clng(Total_Pages) then
if clng(Total_Pages - 1) = clng(CurrentPageNumber) then
high = CurrentPageNumber + 1
else
high = CurrentPageNumber + 2
end if
end if
'How many on last number
LastNum = numResults * (CurrentPagenumber + 1) - (numResults-1)
LastCount = ((Total_Pages - 1) * numResults) + 1
if lResultCount > 0 then%>
<DIV class="displayResultsPageNumberContainer">
<div class="displayResultsPrevious">
<% if Page_Num > 1 then %>
<A id="Page<%=PageNumber%>" style="color:#6b98b4;" href="Display_Results.asp?cboCountry=<%=lCountryID%>&cboFeature=<%=request.QueryString("cboFeature")%>&cboRegion=<%=lCountyID%>&cboService=<%=lServiceID%>&asfTypes=<%=sTypes%>&CityID=<%=lSearchCity%>&asfFeatures=<%=lFeatureID%><%if iHotOffer > 0 then response.Write("&HotOffer=Y") end if%>&results=<%=FirstNum%>&st=<%=CurrentPagenumber-1%>"><<Previous</A>
<% else %>
<% end if %>
</div>
<% if cint(Page_Num) < cint(Total_Pages) then
%>
<div style="float:right; margin-right:10px;"><A style="color:#6b98b4;" id="Page<%=PageNumber%>" href="Display_Results.asp?cboCountry=<%=lCountryID%>&cboFeature=<%=request.QueryString("cboFeature")%>&cboRegion=<%=lCountyID%>&cboService=<%=lServiceID%>&asfTypes=<%=sTypes%>&CityID=<%=lSearchCity%>&asfFeatures=<%=lFeatureID%><%if iHotOffer > 0 then response.Write("&HotOffer=Y") end if%>&st=<%=CurrentPagenumber+1%>&results=<%=LastNum%>">Next >></a></div>
<% end if %>
</DIV>
<%end if
Do Until Query_Result.EOF or count > endd
if (count >= strt) AND (count <= endd) then
Image_Query = "Advert_Images_Get "&Query_Result("Advert_ID")
Set Image_Query_Result = Server.CreateObject("ADODB.Recordset")
Image_Query_Result.Open Image_Query, ObjConn
if not Image_Query_Result.eof then
ImgThumb = replace(Image_Query_Result("Image_Name"),".jpg","_db_mid.jpg")
else
ImgThumb = "1pxSpacer.gif"
end if
%>
<div class="search_result_advert">
<% newCity = replace(Query_Result("City"),",","_") %>
<div class="search_result_advert_img">
<div><a title="View Advert - <%=Query_Result("Title")%>" href="<%=getFilename(newCity, Query_Result("Title"), Query_Result("Advert_ID"))%>"><img src="adverts_pics/<%=ImgThumb%>" alt="<%=Query_Result("Title")%>" border="0" /></a></div>
</div>
<div class="search_result_advert_details">
<div style="float:right;"><a style="color:#6b98b4;" title="View Advert - <%=Query_Result("Title")%>" href="<%=getFilename(newCity, Query_Result("Title"), Query_Result("Advert_ID"))%>">More Info</a></div>
<h3><a id="Result<%=Query_Result("Advert_ID")%>" title="View Advert - <%=Query_Result("Title")%>" href="<%=getFilename(newCity, Query_Result("Title"), Query_Result("Advert_ID"))%>"><%=ucase(TruncateString(Query_Result("Title"),30))%></a></h3>
<div style="margin-top:5px;"><%=TruncateString(Query_Result("Description"), 320)%></div>
</div>
</div>
<div style="margin-top:10px; height:5px;"></div>
<%
end if
count = count + 1
Query_Result.MoveNext
Loop
%>
<%if lResultCount > 0 then%>
<DIV class="displayResultsPageNumberContainer">
<div class="displayResultsPrevious">
<% if Page_Num > 1 then %>
<A style="color:#6b98b4;" id="Page<%=PageNumber%>" href="Display_Results.asp?cboCountry=<%=lCountryID%>&cboFeature=<%=request.QueryString("cboFeature")%>&cboRegion=<%=lCountyID%>&cboService=<%=lServiceID%>&asfTypes=<%=sTypes%>&CityID=<%=lSearchCity%>&asfFeatures=<%=lFeatureID%><%if iHotOffer > 0 then response.Write("&HotOffer=Y") end if%>&results=<%=FirstNum%>&st=<%=CurrentPagenumber-1%>"><< Previous</A>
<% else %>
<% end if %>
</div>
<!--<div class="displayResultsPageNumber">Displaying <b><%=PageStart%> - <%=PageEnd%> of <%=lResultCount%> Search Results for </b></div>-->
<% if cint(Page_Num) < cint(Total_Pages) then
%>
<div style="float:right; margin-right:10px;"><A style="color:#6b98b4;" id="Page<%=PageNumber%>" href="Display_Results.asp?cboCountry=<%=lCountryID%>&cboFeature=<%=request.QueryString("cboFeature")%>&cboRegion=<%=lCountyID%>&cboService=<%=lServiceID%>&asfTypes=<%=sTypes%>&CityID=<%=lSearchCity%>&asfFeatures=<%=lFeatureID%><%if iHotOffer > 0 then response.Write("&HotOffer=Y") end if%>&st=<%=CurrentPagenumber+1%>&results=<%=LastNum%>">Next >></a></div>
<% end if %>
</DIV>
<%end if%>
<br/>
<br/>
<div class="advanced_bg">
<div style="float:left;"><img src="images/img_advanced.jpg" alt="Advanced Search"/></div>
<div id="advanced_title"> <%=Top_PAGECONTENT_Title%></div>
<%=Top_PAGECONTENT_Content%>
</div>
</div>
<%
'<!--#include file="includes/content/hdg_right.asp"-->
%>
</div>
</div>
<div id="footer"><!--#include file="includes/content/hdg_Footer.asp"--> </div>
</div>
</body>
</html>
<!--#include file="includes/scripts/DatabaseConnectClose.asp"-->
without you showing the code, it would be difficult to determine exactly what is going on, but my best guess would that your form method is set to "get" and not "post".
it is for this reason all these value pairs are displaying in the URL.
In addition, the ID you are wanting to be there as well, is this perhaps currently in a hidden field??