|
i aready knew that
i wrote some GA's in the past
GP is somthing else
i already have GP/GA working in liberty/just basic
i m just not knowing how to do it in vb2017 jet
i have some detail's wrong
|
|
|
|
|
As far as I can understand you want just to migrate your code into VB.NET 2017 ?
At the present time I'm just a bit busy, but will help you out later on. 
I'll post the ready code as the reply to your message today, but a little bit later.
|
|
|
|
|
Module Module1
Public Const gp_add As String = "[ + # # ]"
Public Const gp_sub As String = "[ - # # ]"
Public Const gp_mul As String = "[ * # # ]"
Public Const gp_div As String = "[ / # # ]"
Public Const gp_sqrt As String = "[ sqrt # # ]"
Public Class GeneProg
Private genes As Collection
Private Enum numMode As Integer
OnlyInputs = 0
AsDouble = 1
AsInteger = 2
End Enum
Private gpstate As numMode
Public Sub New()
gpstate = numMode.OnlyInputs
End Sub
Public Sub use(gen As String)
genes.Add(gen)
End Sub
Public Function run(prog As String) As String
While InStr(prog, "]") <> 0
Dim eind As Int16 = InStr(prog, "]")
Dim begin As Int16 = eind
While Mid(prog, begin, 1) <> "["
begin -= 1
End While
Dim part As String = Mid(prog _
, begin, eind - begin + 1)
Dim q() As String = Split(part)
Dim a As Double = Val(q(2))
Dim b As Double = Val(q(3))
Dim ab As Double
Try
Select Case q(1)
Case "+"
ab = a + b
Case "-"
ab = a - b
Case "*"
ab = a * b
Case "/"
If b = 0 Then
Return "error"
Else
ab = a / b
End If
Case "sqrt"
ab = Math.Sqrt(a)
Case Else
Return "error"
End Select
Catch ex As Exception
Return "error"
End Try
Dim l As String = Left(prog, begin - 1)
Dim r As String = Right(prog _
, Len(prog) - eind)
prog = l + Str(ab) + r
End While
Return prog
End Function
Public Function mix(pa As String, pb As String) As String
Dim begina As Int16
Dim einda As Int16
Dim beginb As Int16
Dim eindb As Int16
Dim random As Int16
Dim cola As New Collection
Dim colb As New Collection
If Rnd() < 0.5 Then
Dim q As String = pa
pa = pb
pb = q
End If
Dim i As Integer
For i = 1 To Len(pa)
If Mid(pa, i, 1) = "[" Then
cola.Add(i)
End If
Next
For i = 1 To Len(pb)
If Mid(pb, i, 1) = "[" Then
colb.Add(i)
End If
Next
random = CInt(Rnd()) + 1
If random > cola.Count() Then
random = cola.Count() - 1
End If
begina = cola.Item(random)
einda = begina
Dim fl As Int16 = 0
While fl > 0
einda += 1
If Mid(pa, einda, 1) = "]" Then fl -= 1
If Mid(pa, einda, 1) = "[" Then fl += 1
End While
random = CInt(Rnd()) + 1
If random > cola.Count() Then
random = cola.Count() - 1
End If
beginb = colb.Item(random)
fl = 0
While fl > 0
eindb += 1
If Mid(pb, eindb, 1) = "]" Then fl -= 1
If Mid(pb, eindb, 1) = "[" Then fl += 1
End While
Return Left(pa, begina)
End Function
End Class
Sub Main()
Dim proga As String = "[ + 7 [ - 2 3 ] ]"
Dim progb As String = "[ * 4 [ / 5 6 ] ]"
Dim GP As New GeneProg()
Console.WriteLine("[ test run ]")
Console.WriteLine("prog a = " & proga)
Console.WriteLine("prog b = " & progb)
Console.WriteLine("run a = " & GP.run(proga))
Console.WriteLine("check a = " _
& 7.0 + (2.0 - 3.0))
Console.WriteLine("run b = " & GP.run(progb))
Console.WriteLine("check b =" _
& 4.0 * (5.0 / 6.0))
Console.WriteLine("[ push return ]")
Console.ReadKey()
Console.WriteLine("[ test mix ]")
Dim i As Int16
For i = 0 To 5
Dim c As String = GP.mix(proga, progb)
Console.WriteLine("mix a b = c = " & c)
Console.WriteLine("run c = " & c)
Next
Console.WriteLine("[ push return ]")
Console.ReadKey()
End Sub
End Module
|
|
|
|
|
Here's the corrected code in VB.NET 2017. I've made some small improvements of code to avoid the number of runtime errors. I actually can't figure out what particular algorithm you're about to implement. So, if you want me to delve into your code more deep, please let me know about the algorithm.
Are you actually trying to develop a code that performs a reverse 'polish notation' to parse math expressions ?
|
|
|
|
|
the problem whit basic is that the
operant is not on the same place every time
parsing is a lot easyer that way
do you have use for the liberty/just code
than we wil have translated it earlyer ?
'' bluatigro 4 sept 2017
'' genetic programming module
Module Module1
Public Const gp_add As String = "[ + # # ]"
Public Const gp_sub As String = "[ - # # ]"
Public Const gp_mul As String = "[ * # # ]"
Public Const gp_div As String = "[ / # # ]"
Public Const gp_sqrt As String = "[ sqrt # # ]"
Public Class GeneProg
Private genes As Collection
Private Enum numMode As Integer
OnlyInputs = 0
AsDouble = 1
AsInteger = 2
End Enum
Private gpstate As numMode
Public Sub New()
gpstate = numMode.OnlyInputs
End Sub
Public Sub use(gen As String)
genes.Add(gen)
End Sub
Public Function run(prog As String) As String
While InStr(prog, "]") <> 0
Dim eind As Int16 = InStr(prog, "]")
Dim bgin As Int16 = eind
While Mid(prog, bgin, 1) <> "["
bgin -= 1
End While
Dim part As String = Mid(prog _
, bgin, eind - bgin + 1)
Dim q() As String = Split(part)
Dim a As Double = Val(q(2))
Dim b As Double = Val(q(3))
Dim ab As Double
Try
Select Case q(1)
Case "+"
ab = a + b
Case "-"
ab = a - b
Case "*"
ab = a * b
Case "/"
If b = 0 Then
Return "error"
Else
ab = a / b
End If
Case "sqrt"
ab = Math.Sqrt(a)
Case Else
Return "error"
End Select
Catch ex As Exception
Return "error"
End Try
Dim l As String = Left(prog, bgin - 1)
Dim r As String = Right(prog _
, Len(prog) - eind)
prog = l + Str(ab) + r
End While
Return prog
End Function
Public Function mix(pa As String, pb As String) As String
Dim begina As Int16
Dim einda As Int16
Dim beginb As Int16
Dim eindb As Int16
Dim cola As New Collection
Dim colb As New Collection
If Rnd() < 0.5 Then
Dim q As String = pa
pa = pb
pb = q
End If
Dim i As Integer
For i = 1 To Len(pa)
If Mid(pa, i, 1) = "[" Then
cola.Add(i)
End If
Next
For i = 1 To Len(pb)
If Mid(pb, i, 1) = "[" Then
colb.Add(i)
End If
Next
begina = cola.Item(random)
einda = begina
Dim fl As Int16 = 0
While fl > 0
einda += 1
If Mid(pa, einda, 1) = "]" Then fl -= 1
If Mid(pa, einda, 1) = "[" Then fl += 1
End While
beginb = colb.Item(random)
fl = 0
While fl > 0
eindb += 1
If Mid(pb, eindb, 1) = "]" Then fl -= 1
If Mid(pb, eindb, 1) = "[" Then fl += 1
End While
dim l as string = left(pa, begina - 1)
dim m as string = mid(pb ,beginb ,eindb - beginb)
dim r as string = right(pa ,len(pa) - eindea + 1 )
Return l + m + r
End Function
End Class
Sub Main()
Dim proga As String = "[ + 7 [ - 2 3 ] ]"
Dim progb As String = "[ * 4 [ / 5 6 ] ]"
Dim GP As New GeneProg()
Console.WriteLine("[ test run ]")
Console.WriteLine("prog a = " & proga)
Console.WriteLine("prog b = " & progb)
Console.WriteLine("run a = " & GP.run(proga))
Console.WriteLine("check a = " _
& 7.0 + (2.0 - 3.0))
Console.WriteLine("run b = " & GP.run(progb))
Console.WriteLine("check b =" _
& 4.0 * (5.0 / 6.0))
Console.WriteLine("[ push return ]")
Console.ReadKey()
Console.WriteLine("[ test mix ]")
Dim i As Int16
For i = 0 To 5
Dim c As String = GP.mix(proga, progb)
Console.WriteLine("mix a b = c = " & c)
Console.WriteLine("run c = " & c)
Next
Console.WriteLine("[ push return ]")
Console.ReadKey()
End Sub
End Module
modified 7-Sep-17 4:33am.
|
|
|
|
|
to expand the code
WARNING :
i dont think i got it al right
please look at it
how do i do :
wrd.count() [ see code ]
'' bluatigro 7 sept 2017
'' genetic programming module
Module Module1
'' function gene's
Public Const gp_add As String = "[ + # # ]"
Public Const gp_sub As String = "[ - # # ]"
Public Const gp_mul As String = "[ * # # ]"
Public Const gp_div As String = "[ / # # ]"
Public Const gp_sqrt As String = "[ sqrt # # ]"
public const vars as string = "xyzdefgh"
Public Class GeneProg
Private genes As Collection
Private Enum numMode As Integer
OnlyInputs = 0
AsDouble = 1
AsInteger = 2
End Enum
Private gpstate As numMode
private varMax as int16
private var(8) as double
private growthrate as double
private progLenMax as int16
Public Sub New()
gpstate = numMode.OnlyInputs
varmax = 0
growthrate = 0.2
progLenMax = 200
End Sub
Public Sub use(gen As String)
'' for activation of a functiongen or number
genes.Add(gen)
End Sub
public sub setVarMax( m as int16 )
'' how many variables seting
if m < 1 or m > len(vars) then exit sub
dim i as int16
for i = 1 to m
use(mid(vars, i, 1))
next i
end sub
public sub setVar(no as int16, q as double)
'' set variable
'' only as set var max is set this is useful
if no < 1 or no > len(vars) then exit sub
var(no) = q
end sub
public sub useIntegers()
'' create a set of integer gene's
'' and set writing to integer's
dim i as int16
for i = 0 to 31
use(str(2 ^ i))
use(str(-(2 ^ i)))
next i
use("0")
gpstate = numMode.asinteger
end sub
public sub useDoubles()
'' create a set of double gene's
'' and set writing to double's
dim i as int16
for i = -31 to 31
use(str(2 ^ i))
use(str(-(2 ^ i)))
next i
use("0")
gpstate = numMode.asdouble
end sub
private function isVar(x as string)as bool
return len(x) = 1 and instr(vars, x)
end function
private function isFunctionGen(x as string) as bool
return left(x, 1) = "["
end function
private function isNumber(x as string) as bool
return val(x)<>0 or x = "0" or x = "0.0"
end function
Public Function run(prog As String) As String
'' parse formula
'' return a double in a string if succes
'' return "error" if iligal calculation
While InStr(prog, "]") <> 0
Dim eind As Int16 = InStr(prog, "]")
Dim bgin As Int16 = eind
While Mid(prog, bgin, 1) <> "["
bgin -= 1
End While
Dim part As String = Mid(prog _
, bgin, eind - bgin + 1)
Dim q() As String = Split(part)
Dim a As Double = Val(q(2))
Dim b As Double = Val(q(3))
Dim ab As Double
Try
Select Case q(1)
Case "+"
ab = a + b
Case "-"
ab = a - b
Case "*"
ab = a * b
Case "/"
If b = 0 Then
Return "error"
Else
ab = a / b
End If
Case "sqrt"
ab = Math.Sqrt(a)
Case Else
Return "error"
End Select
Catch ex As Exception
Return "error"
End Try
Dim l As String = Left(prog, bgin - 1)
Dim r As String = Right(prog _
, Len(prog) - eind)
prog = l + Str(ab) + r
End While
Return prog
End Function
Public Function mix(pa As String, pb As String) As String
'' crosover
'' put a random part of pa in the place
'' of a random part of pb
'' or visa versa
Dim begina As Int16
Dim einda As Int16
Dim beginb As Int16
Dim eindb As Int16
Dim cola As New Collection
Dim colb As New Collection
If Rnd() < 0.5 Then
Dim q As String = pa
pa = pb
pb = q
End If
Dim i As Integer
For i = 1 To Len(pa)
If Mid(pa, i, 1) = "[" Then
cola.Add(i)
End If
Next
For i = 1 To Len(pb)
If Mid(pb, i, 1) = "[" Then
colb.Add(i)
End If
Next
begina = cola.Item(random)
einda = begina
Dim fl As Int16 = 0
While fl > 0
einda += 1
If Mid(pa, einda, 1) = "]" Then fl -= 1
If Mid(pa, einda, 1) = "[" Then fl += 1
End While
beginb = colb.Item(random)
fl = 0
While fl > 0
eindb += 1
If Mid(pb, eindb, 1) = "]" Then fl -= 1
If Mid(pb, eindb, 1) = "[" Then fl += 1
End While
dim l as string = left(pa, begina - 1)
dim m as string = mid(pb ,beginb ,eindb - beginb)
dim r as string = right(pa ,len(pa) - einda + 1 )
Return l + m + r
End Function
public function write( hookmax as int16 ) as string
'' write a program whit the activated genes
'' get a function gene for seed
dim dice as int16 = int( rnd( 0 ) * genes.count() )
while not( isfunctionGene( genes.item( dice ) ) )
dice = int( rnd( 0 ) * genes.count() )
wend
dim uit as string = genes.item( dice )
dim hook as int16
dim p as int16
while instr( uit, "#" ) <> 0 _
and hook < hookmax
p = instr( uit , "#" )
dice = int( rnd( 0 ) * genes.count() )
dim l as string = left( uit , p - 1 )
dim r as string = right( uit , len( uit ) - p )
uit = l + " " + gene.item( dice ) + r
if isFunctioGene( gene.item( dice ) ) then
hook = hook + 1
end if
end while
uit = lastsharp( uit )
if rnd() < growthrate _
and len( uit ) < progLenMax then
uit = growth( uit )
end if
return uit
end function
private function lastsharp( uit as string ) as string
'' replace al # whit number's or var's
while instr( uit$, "#" ) <> 0
dim p as int16 = instr( uit , "#" )
dim dice as int16 = int( rnd( 0 ) * genes.count() )
while isFunctionGene( genes.item( dice ) )
dice = int( rnd( 0 ) * genes.count() )
end while
dim l as string = left( uit , p - 1 )
dim r as string = right( uit , len( uit ) - p )
uit = l + " " + genes.item( dice ) + r
end while
return uit
end function
private function growth( a as string )as string
'' make the formula a longer
dim wrd() as string = split(a)
dim dice as int16 = int( rnd() * wrd.count() + 1 )
while not( isVar( wrd( dice ) ) ) _
and not( isNumber( wrd( dice ) ) )
dice = int( rnd() * tel + 1 )
end while
dim atom as string = wrd( dice )
dim dice2 as int16 = int( rnd(0) * genes.count() )
while not( isFunctionGene( gene( dice2 ) ) )
dice2 = int( rnd(0) * gene.count() )
end while
dim gen as string = genes.item( dice2 )
uit = ""
dim i as int16
for i = 1 to wrd.count()
if i = dice then
uit = uit + gen + " "
else
uit = uit + wrd( i ) + " "
end if
next i
return lastsharp( uit )
end function
public function mutate( a as string )as string
'' mutate formula a
dim wrd() as string = split(a)
''take a atom that isnt a hook or empty
dim dice as int16 = int( rnd() * wrd.count() )
while wrd( dice ) = "[" _
or wrd( dice ) = "]" _
or wrd( dice ) = ""
dice = int( rnd( 0 ) * wrd.count() )
end while
dim atom as string = wrd( dice )
if isVar( atom ) then
if rnd() < .6 then
atom = mid( vars _
, int( rnd() * varMax ) , 1 )
else
select case gpstate
case numMode.Asintegers
atom = str( 2 _
^ ( int( rnd() * 32 ) ) )
case nummode.asdoubles
atom = str( 2 _
^ ( int( rnd() * 64 - 32 ) ) )
case else
atom = mid( vars _
, int( rnd() * ( varMax - 1 ) + 1 ) _
, 1 )
end select
end if
else
if isNumber( atom ) then
select case gpstate
case nummode.asintegers
dim x as double = val( atom )
atom = str( x _
xor 2 ^ int( rnd() * 32 ) )
case else ''doubles
dim x as double = val( atom )
dim q as double = 2 ^ int( rnd(0) * 64 - 32 )
if rnd() < .5 then
atom = str( x - q )
else
atom = str( x + q )
end if
end select
if varMax > 0 then
if rnd(0) < .4 then
atom = mid( vars _
, int( rnd() * ( varMax - 1 ) + 1 ) _
, 1 )
end if
end if
else
'' atom is a function
dim q as int16 = 0
while not( isFunctionGene( gene.item( q ) ) )
q = int( rnd( 0 ) * genes.count() )
wend
dim w() as string = split( genes.item(q) )
atom = w( 1 )
end if
end if
dim uit as string
wrd(dice)=atom
for i = 1 to tel + 2
uit = uit + wrd( i ) + " "
next i
if rnd() < .2 _
and len( uit ) < proglenmax then
uit = growth( uit )
end if
return uit
end function
End Class
Sub Main()
Dim proga As String = "[ + 7 [ - 2 3 ] ]"
Dim progb As String = "[ * 4 [ / 5 6 ] ]"
Dim GP As New GeneProg()
Console.WriteLine("[ test run ]")
Console.WriteLine("prog a = " & proga)
Console.WriteLine("prog b = " & progb)
Console.WriteLine("run a = " & GP.run(proga))
Console.WriteLine("check a = " _
& 7.0 + (2.0 - 3.0))
Console.WriteLine("run b = " & GP.run(progb))
Console.WriteLine("check b =" _
& 4.0 * (5.0 / 6.0))
Console.WriteLine("[ push return to continue ]")
Console.ReadKey()
Console.WriteLine("[ test mix ]")
Console.WriteLine("prog a = " & proga)
Console.WriteLine("prog b = " & progb)
Dim i As Int16
dim c as string
For i = 0 To 5
c = GP.mix(proga, progb)
Console.WriteLine("mix a b = c = " & c)
Console.WriteLine("run c = " & c)
Next
Console.WriteLine("[ push return to continue ]")
Console.ReadKey()
console.writeline("[ test mutate ]"
''gp.mutate needs this :
gp.use(gp_add)
gp.use(gp_sub)
gp.use(gp_mul)
gp.use(gp_div)
gp.use(gp_sqrt)
gp.useintegers()
Console.WriteLine("prog a = " & proga)
dim progc as string
for i = 0 to 5
progc = gp.mutate(proga)
console.writeline("mutate a = c = "&progc)
consolo.writeline("run c = "&gp.run(progc))
next i
console.writeline("[ push return to continue ]")
console.readkey()
console.writeline("[ test write ]"
for i = 0 to 5
progc = gp.write(6)
console.writeline("write c = "&progc)
consolo.writeline("run c = "&gp.run(progc))
next i
console.writeline("[ push return to end programma ]")
console.readkey()
End Sub
End Module
|
|
|
|
|
Quote: the 'language' i use is based on lisp
Unfortunately, I'm not familiar with LISP programming.
Quote: the problem whit basic is that the
operant is not on the same place every time
parsing is a lot easyer that way
Quote:
do you have use for the liberty/just code
than we wil have translated it earlyer ?
And yes, parsing is much easier in this particular case. Since that, just change the algorithm.
Anyway, what you've implemented is *NOT* a genetic algorithm in whatever language you have used.
Quote: do you have use for the liberty/just code
than we wil have translated it earlyer ?
To parse math expressions I would recommend that reverse 'polish notation' algorithm is a good one.
Just give a try to implement it by using LISP, or Liberty BASIC, or VB.NET 2017, or whatsoever.
Also, I would recommend you to start the development using VB.NET 2017 right from the very beginning, so that there will be no need to rework the code from other languages such LISP or Liberty BASIC.
|
|
|
|
|
Probably, this is a correct solution. Just check it:
Module Module1
Function Compute(expr As String)
Dim Result As Int32 = 0
Dim val As String = ""
Dim op() As String = {"+", "-", "*", "/"}
Dim strings As List(Of String) = New List(Of String)
For index = 0 To expr.Length() - 1 Step 1
If IsNumeric(expr(index)) Then
val = Nothing
Dim done As Boolean = False
While index < expr.Length() And done = False
If IsNumeric(expr(index)) Then
val += expr(index)
index = index + 1
Else done = True
End If
End While
strings.Add(val)
ElseIf expr(index) = op(0) Then
strings.Add(op(0))
ElseIf expr(index) = op(1) Then
strings.Add(op(1))
ElseIf expr(index) = op(2) Then
strings.Add(op(2))
ElseIf expr(index) = op(3) Then
strings.Add(op(3))
End If
Next
Dim n As Int32 = 0
While strings.Contains("*") Or strings.Contains("/")
Dim found As Boolean = False
While n < strings.Count() And found = False
If strings(n) = op(2) Then
Dim op1 As Int32 = Integer.Parse(strings(n - 1))
Dim op2 As Int32 = Integer.Parse(strings(n + 1))
Dim Res = op1 * op2
strings.RemoveAt(n - 1)
strings(n - 1) = Res
strings.RemoveAt(n)
Result = Res
found = True
n = 0
End If
If strings(n) = op(3) Then
Dim op1 As Int32 = Integer.Parse(strings(n - 1))
Dim op2 As Int32 = Integer.Parse(strings(n + 1))
Dim Res = CInt(op1 / op2)
strings.RemoveAt(n - 1)
strings(n - 1) = Res
strings.RemoveAt(n)
Result = Res
found = True
n = 0
End If
n = n + 1
End While
End While
n = 0
While strings.Contains("+") Or strings.Contains("-")
Dim found As Boolean = False
While n < strings.Count() And found = False
If strings(n) = op(0) Then
Dim op1 As Int32 = Integer.Parse(strings(n - 1))
Dim op2 As Int32 = Integer.Parse(strings(n + 1))
Dim Res = op1 + op2
strings.RemoveAt(n - 1)
strings(n - 1) = Res
strings.RemoveAt(n)
Result = Res
found = True
n = 0
End If
If strings(n) = op(1) Then
Dim op1 As Int32 = Integer.Parse(strings(n - 1))
Dim op2 As Int32 = Integer.Parse(strings(n + 1))
Dim Res = op1 - op2
strings.RemoveAt(n - 1)
strings(n - 1) = Res
strings.RemoveAt(n)
Result = Res
found = True
n = 0
End If
n = n + 1
End While
End While
Return Result
End Function
Function Parse(input As String)
Dim t As Int32 = 0
Dim oe(0) As Int32
Dim strings As List(Of String) = New List(Of String)
For index = input.Length() - 1 To 0 Step -1
If input(index) = "(" Or index = 0 Then
Dim sb As String = ""
Dim n As Int32 = 0
If index = 0 Then
n = index
Else n = index + 1
End If
Dim exists As Boolean = False
Do
exists = False
Dim bracket As Boolean = False
While n < input.Length() And bracket = False
If input(n) <> ")" Then
sb += input(n)
Else bracket = True
End If
n = n + 1
End While
If exists <> True Then
Dim r As Int32 = 0
While r < oe.Count() And exists = False
If oe(r) = n Then
exists = True
sb += ") "
n = n + 1
End If
r = r + 1
End While
End If
Loop While exists = True
If exists = False Then
Array.Resize(oe, oe.Length + 1)
oe(t) = n
t = t + 1
End If
strings.Add(sb)
End If
Next
For index = 0 To strings.Count() - 1 Step 1
Dim Result As String = Compute(strings.Item(index)).ToString()
For n = index To strings.Count() - 1 Step 1
strings(n) = strings.ElementAt(n).Replace("(" + strings.Item(index) + ")", Result)
Next
Next
Return Compute(strings.Item(strings.Count() - 1))
End Function
Sub Main()
Dim input As String = "1769 - (40 + 80 / (60 - 1 * 20) + 6) / 15 + 1"
Console.WriteLine(input)
Console.WriteLine("Result = {0}", Parse(input))
Console.ReadKey()
End Sub
End Module
Looking forward to your feedback.
|
|
|
|
|
@ arthur v raz :
nice try
how does parse report a iligal calulation ?
|
|
|
|
|
okey, I'll give a try it later on.
|
|
|
|
|
<pre>Hi,
I am pretty new to VBscripts. I am trying to use a VBscript to copy calendar entries from an excel spreadsheet into an Outlook Calendar. I have found on forums this script below:
Dim objExcel, objWorkbook
Dim objOutlook, objNameSpace, objFolder, foundItems, objAppt
Dim i, j, strFilter
Const olFolderCalendar = 9
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open("C:\VBATest\Dates.xlsx")
objExcel.Application.Visible = False
'objExcel.ActiveWorkbook.Save'
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNameSpace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalendar)
For i = 1 To 3
j = 1
While j > 0
strFilter = "[Start] >= 'objWorkbook.Worksheets(i).Cells(4,2)' AND [Start] <= 'objWorkbook.Worksheets(i).Cells(4,3)' AND [Subject = 'objWorkbook.Worksheets(i).Cells(6,j)'"
Set foundItems = objFolder.Items.Restrict(strFilter)
Set foundItems = objFolder.Items.Restrict(strFilter)
If foundItems.Count = 1 Then foundItems.Item.Delete
Set objAppt = objFolder.Items.Add
With objAppt
.Subject = "objWorkbook.Worsheets(i).Cells(6,j)"
.Body = "objWorkbook.Worsheets(i).Cells(6,j)"
.Start = "objWorkbook.Worsheets(i).Cells(7,j)"
.AllDayEvent = True
.ReminderMinutesBeforeStart = 1440
.Save
End With
Set j = j + 1
If objWorkbook.Worksheets(i).Cells(6, j) = "stop" Then Set j = 0
If objWorkbook.Worksheets(i).Cells(6, j) = "stop" Then j = 0
Wend
Next
objWorkbook.Close False
Set objExcel = Nothing
Set objWorkbook = Nothing
Set objOutlook = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
Set objAppt = Nothing
but I get the below error:
Error on line 20: Cannot parse condition. Error at "[Subject = 'objWorkbook.Worksheets(i).Ce...".
Code 80020009.
Any ideas how I can resolve this?</pre>
|
|
|
|
|
Have you took a look at/with the debugger to see what is (perhaps) missing ?
From where have you got this code-line :
strFilter = "[Start] >= 'objWorkbook.Worksheets(i).Cells(4,2)' AND [Start] <= 'objWorkbook.Worksheets(i).Cells(4,3)' AND [Subject = 'objWorkbook.Worksheets(i).Cells(6,j)'"
|
|
|
|
|
You dont need the quotes in these lines and you have misspelled Worksheets as Worsheets
.subject = "objWorkbook.Worsheets(i).Cells(6,j)"
.Body = "objWorkbook.Worsheets(i).Cells(6,j)"
.Start = "objWorkbook.Worsheets(i).Cells(7,j)"
Change them to:
.Subject = objWorkbook.Worksheets(i).Cells(6,j)
.Body = objWorkbook.Worksheets(i).Cells(6,j)
.Start = objWorkbook.Worksheets(i).Cells(7,j)
=========================================================
I'm an optoholic - my glass is always half full of vodka.
=========================================================
|
|
|
|
|
... and Start and Subject are used before they are assigned ...
|
|
|
|
|
In addition to the answer above, your filter is wrong. You're missing the closing ] around Subject, and you're searching for the literal string objWorkbook.Worksheets(i).Cells(6,j) rather than the value of that cell.
strFilter = "[Start] >= '" & objWorkbook.Worksheets(i).Cells(4,2) & "' AND [Start] <= '" & objWorkbook.Worksheets(i).Cells(4,3) & "' AND [Subject] = '" & objWorkbook.Worksheets(i).Cells(6,j) & "'"
"These people looked deep within my soul and assigned me a number based on the order in which I joined."
- Homer
|
|
|
|
|
Dim objExcel, objWorkbook
Dim objOutlook, objNameSpace, objFolder, foundItems, objAppt
Dim i, j, strFilter
Const olFolderCalendar = 9
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open("C:\VBATest\Dates.xlsx")
objExcel.Application.Visible = False
'objExcel.ActiveWorkbook.Save'
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNameSpace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalendar)
For i = 1 To 3
j = 1
While j > 0
strFilter = "[Start] >= '" & objWorkbook.Worksheets(i).Cells(4,2) & "' AND [Start] <= '" & objWorkbook.Worksheets(i).Cells(4,3) & "' AND [Subject] = '" & objWorkbook.Worksheets(i).Cells(6,j) & "'"
Set foundItems = objFolder.Items.Restrict(strFilter)
Set foundItems = objFolder.Items.Restrict(strFilter)
If foundItems.Count = 1 Then foundItems.Item.Delete
Set objAppt = objFolder.Items.Add
With objAppt
.Subject = objWorkbook.Worksheets(i).Cells(6,j)
.Body = objWorkbook.Worksheets(i).Cells(6,j)
.Start = objWorkbook.Worksheets(i).Cells(7,j)
.AllDayEvent = True
.ReminderMinutesBeforeStart = 1440
.Save
End With
Set j = j + 1
If objWorkbook.Worksheets(i).Cells(6, j) = "stop" Then Set j = 0
If objWorkbook.Worksheets(i).Cells(6, j) = "stop" Then j = 0
Wend
Next
objWorkbook.Close False
Set objExcel = Nothing
Set objWorkbook = Nothing
Set objOutlook = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
Set objAppt = Nothing
I now get the error Line 20 Error: Condition is not valid.
Any ideas?
|
|
|
|
|
Probably a problem with your date formats:
Filtering Items Using a Date-time Comparison[^]
NB: That uses VBA's Format function, which isn't availble in VBScript. You'll need to use FormatDateTime[^] instead:
Dim minDate, maxDate
minDate = FormatDateTime(objWorkbook.Worksheets(i).Cells(4,2), 0)
maxDate = FormatDateTime(objWorkbook.Worksheets(i).Cells(4,3), 0)
For i = 1 To 3
j = 1
While j > 0
strFilter = "[Start] >= '" & minDate & "' AND [Start] <= '" & maxDate & "' AND [Subject] = '" & objWorkbook.Worksheets(i).Cells(6,j) & "'"
...
"These people looked deep within my soul and assigned me a number based on the order in which I joined."
- Homer
|
|
|
|
|
I need to load some icons in jp2 format into an ImageList.
I searched online for a solution, but everything I've found is out of date (I'm using Visual Studio VB 2017.)
There's a free DLL called "FreeImage" for reading & converting image formats, but all VB/.Net code is out of date and the documentation sux rocks. (Images as loaded as "Long" values???)
I've resorted to a simple CLI utility called "ImageMagick" that can I can call from VB to convert jp2's to png's that I can then load normally. This works, but is much too slow if you have a lot of files.
I don't need to manipulate the images in any way, and don't need to save them. I only need to be able to load them.
TIA
|
|
|
|
|
Message Removed
modified 6-Mar-18 16:02pm.
|
|
|
|
|
When i click browse button instead of opening document folder, It should open as per configured path.
Can some one please help me.
|
|
|
|
|
|
<pre lang="text">I am using WebClient.UploadFile to upload local files to a Hostmonster web server. I have code that downloads files from my website correctly but I am new to uploading. If doesn't seem very difficult but I just can't get it to work. I have basically copied the vb.net code from https://msdn.microsoft.com/en-us/library/36s52zhs(v=vs.110).aspx. I am using server side code located in the same folder that the file is being transferred to, referred to as Upload.net and listed below.
<%@ Import Namespace="System"%>
<%@ Import Namespace="System.IO"%>
<%@ Import Namespace="System.Net"%>
<%@ Import NameSpace="System.Web"%>
<Script language="VB" runat=server>
Sub Page_Load(ByVal sender As Object, ByVal e As EventArgs)
Dim f As String
Dim file
For Each f In Request.Files.AllKeys
file = Request.Files(f)
file.SaveAs(Server.MapPath("~/data/" & file.FileName)
Next f
End Sub
</Script>
<html>
<body>
<p> Upload complete. </p>
</body>
</html>
Function TestWcWrite()
Dim LoginUser As String = "testuser"
Dim UserPassword As String = "testpass"
Dim UrlLicensePath As String = "http://www.xxx.com/data/"
Using wc As New System.Net.WebClient()
ServicePointManager.ServerCertificateValidationCallback =
New System.Net.Security.RemoteCertificateValidationCallback(AddressOf CertificateValidation)
wc.Credentials = New System.Net.NetworkCredential(LoginUser, UserPassword)
Dim responseArray As Byte() = wc.UploadFile(UrlLicensePath & "upload.net", "POST", "C:\temp\test.txt")
Console.WriteLine(ControlChars.Cr & "Response Received.The contents of the file uploaded are: " &
ControlChars.Cr & "{0}", System.Text.Encoding.ASCII.GetString(responseArray))
wc.Dispose()
End Using
End Function
The folder I am loading to is password protected and the permissions are set to 777 at this point. I was using Https originally so that is why the RemoteCertificateValidationCallback is in the code. Anyway when I execute the code, the file isn't copied and the response returned is the contents of upload.net file. What am I missing here? Obviously it is something minor.
Thanks for your help,
Bob
|
|
|
|
|
In an existing vb.net 2010 desktop application, I have users that would like all the screens to be larger since some of them say the cannot see the screens.
Thus is there something like a 'zoom' enlarge feature that can be added to the application without having to enlarge all the screens in the application? If so, can you tell me how to accomplish this goal?
If not, would you tell me that also?
|
|
|
|
|
Even better; Windows has some tools built-in to help people with visual limitations, including a magnifier[^]. If that doesn't help them enough, you could change the DPI-setting and/or change the color-scheme to a high-contrast version.
Bastard Programmer from Hell 
If you can't read my code, try converting it here[^]
|
|
|
|
|
The problem is the user has no problems with the other applications. They only want application size to be increased.
|
|
|
|
|
General 
News 
Suggestion 
Question 
Bug 
Answer 
Joke 
Praise 
Rant 
Admin 
Submit an article or tip
