|
|
Titel = "Convert 2004 to 2002"
Datum = "26.01.05"
Version = "V0.1"
'// ******** Main *********
Dim SCHFile(1)
Dim nLine
Dim Wert
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objArgs = Wscript.Arguments
Set filesyso = CreateObject("Scripting.FileSystemObject")
'nutzt VBScript "," oder "." fuer die Zahlendarstellung?
testZ=10/3
If instr(testZ,",") Then
repS=","
'msgbox "Lang: Ger"
Else
repS="."
'msgbox "Lang: Eng"
End If
'// create a link on the desktop if there isn't one
desktopdir = wshshell.SpecialFolders(0)
newlink = desktopdir & "\Con04_02.lnk"
If (filesyso.FileExists(newlink))=False Then
back = msgbox ("You need a shortcut on the desktop to" & vbCrlf &_
"work with the program. Can I create one?" & vbCrlf & vbCrlf &_
"Es wird eine Desktopverknьpfung benцtigt," & vbCrlf &_
"um mit dem Programm zu arbeiten. Kann ich" & vbCrlf &_
"eine anlegen?" & vbCrlf _
,4+32,Titel&" "&Version)
If back = 7 Then
Wscript.Quit(1)
End If
scriptname = WScript.ScriptFullName
Set link = wshshell.Createshortcut(newlink)
link.TargetPath = scriptname
icoName = Left(scriptname, InstrRev(scriptname, "\")) & "Con04_02.ico"
If (filesyso.FileExists(icoName)) Then
link.IconLocation = icoName & " ,0"
End If
link.Save
Wscript.Quit(2)
End If
If (objArgs.Count > 1) Then
MsgBox "Too many files!" & vbCrlf & vbCrlf & "Zu viele Dateien!",48,Titel&" "&Version
Wscript.Quit(2)
End If
If (objArgs.Count = 0) Then
MsgBox "Drop your PCAD 2004-Ascii-File onto" & vbCrlf &_
"the icon on the desktop." & vbCrlf &_
"The program generates an new file in" & vbCrlf &_
"the directory of the source file with the" & vbCrlf &_
"extension .2002" & vbCrlf & vbCrlf &_
"Das PCAD 2004-Ascii-File auf das " & vbCrlf &_
"Desktopicon ziehen. Das Programm " & vbCrlf &_
"erzeugt dann ein neues File mit der " & vbCrlf &_
"Extension .2002 im Ordner der" & vbCrlf &_
"Originaldatei.",64,Titel&" "&Version
Wscript.Quit(3)
End If
SCHFile(0) = objArgs(0)
Set MyFile = filesyso.OpenTextFile(SCHFile(0),1)
Set OutFile = filesyso.CreateTextFile(left(SCHFile(0),len(SCHFile(0))) & ".2002",1)
myEnd = 1
delKl = 1
While (MyFile.AtEndOfStream = False)
Line = MyFile.ReadLine
anfZeile = ""
myOut = 1
'Layerpairs rausschmeissen
Comp = "(layerPair"
found = inStr(Line, Comp)
While found >0
delKl=0
Line = MyFile.ReadLine
found = inStr(Line, Comp)
Wend
If delKl=0 Then
'msgbox Line
Line = ""
delKl=1
End If
'RightReading raus
Comp = "(isRightReading True)"
found = InStr(Line, Comp)
If found >0 Then
Line = Left(Line,found-1) & Mid(Line,found+21)
found=0
'msgbox line
End If
'LayerStack raus
Comp = "(layersStackup"
found = InStr(Line, Comp)
If found>0 Then myEnd = 0
'Arcs umrechnen
Comp = "(triplePointArc"
found = InStr(Line, Comp)
If found>0 Then
anfZeile=left(Line,found-1)
'msgbox anfZeile
myOut = 0
'Zeile mit arc ist jetzt in Line
'aufsplitten, umrechnen und neue zeile "Line" erzeugen
'MsgBox Line
Mitte=getPair(mid(line,found+2))
'msgbox mitte
found=found+len(Mitte)
Mitte=getKoor(Mitte)
Mi=splKoor(Mitte,xE,yE,mx,my)
'msgbox "E" & xE & ":" & mx & "#" & "E" & yE & ":" & my
P1=getPair(mid(line,found+6))
found=found+len(P1)
'msgbox p1
P1=getKoor(P1)
P1=splKoor(P1,xE,yE,x1,y1)
'msgbox "E" & xE & ":" & x1 & "#" & "E" & yE & ":" & y1
P2=getPair(mid(line,found+10))
found=found+len(P2)
'msgbox p2
P2=getKoor(P2)
P2=splKoor(P2,xE,yE,x2,y2)
'msgbox "E" & xE & ":" & x2 & "#" & "E" & yE & ":" & y2
Weit=getPair(mid(line,found+16))
'MsgBox Weit
dx1=mx-x1
dy1=my-y1
dx2=mx-x2
dy2=my-y2
radius=sqr((dx1 * dx1) + (dy1 * dy1))
'msgbox radius
If dx1=0 Then
If dy1<=0 Then
startAng = 90
Else
startAng = 270
End If
Else
startAng=atn(dy1/dx1) * 57.29577951
End If
If dx2=0 Then
If dy2<=0 Then
stopAng = 90
Else
stopAng = 270
End If
Else
stopAng=atn(dy2/dx2) * 57.29577951
End If
'msgbox startAng & " # " & stopAng
'If (dx1<0) And (dy1<0) Then startAng = 0 + startAng
If (dx1>0) And (dy1<0) Then startAng = 180.0 + startAng : 'msgbox "1"
If (dx1>0) And (dy1>=0) Then startAng = 180.0 + startAng : 'msgbox "2"
If (dx1<0) And (dy1>0) Then startAng = 360.0 + startAng : 'msgbox "3"
'If (dx20) And (dy20) Then stopAng = 0 + stopAng
If (dx2>0) And (dy2<0) Then stopAng = 180.0 + stopAng : 'msgbox "4"
If (dx2>0) And (dy2>=0) Then stopAng = 180.0 + stopAng : 'msgbox "5"
If (dx2<0) And (dy2>0) Then stopAng = 360.0 + stopAng : 'msgbox "6"
sweepAng = stopAng - startAng
If sweepAng < 0 Then
sweepAng = 360 + sweepAng
End If
If (sweepAng=0) And (startAng=0) Then
startAng=0
sweepAng=360
End If
startAng=round(startAng,1)
sweepAng=round(sweepAng,1)
radius=round(radius,1)
mx=round(mx,1)
my=round(my,1)
startAng = komma(startAng)
sweepAng = komma(sweepAng)
radius = komma(radius)
mx = komma(mx)
my = komma(my)
'msgbox mx & " # " & my & " # " & startAng & " # " & sweepAng & " # " & radius
nText = " (arc (pt " & mx & " " & my & ") (radius " & radius & ") (startAngle " & startAng & ") (sweepAngle " & sweepAng & ") " & weit & " )"
'msgbox nText
Line = anfZeile & nText
myout = 1
End If
If myout >0 Then
If myEnd >0 Then
OutFile.Write(Line)
OutFile.Write Vbcrlf
End If
End If
Wend
'Konvertierung zu ende
If myEnd=0 Then
OutFile.Write(")")
OutFile.Write Vbcrlf
End If
MyFile.close
OutFile.close
Comp = "Conversion done." & vbCrlf
back = wshshell.Popup(Comp,500,Titel&" "&Version)
Wscript.Quit(0)
Function komma(zahl)
help=""
nZahl=""
For i=1 To len(zahl)
help=mid(zahl,i,1)
If help="," Then help = "."
nZahl = nZahl & help
Next
komma=nZahl
End Function
Function getKoor(paar)
help = ""
nnenn = ""
For i = 1 To len(paar)
help = mid(paar,i,1)
If isNumeric(help) Or (help=",") Or (help=".") Or (help=" ") Or (help="-") Or (help="m") Then
If help="." Then help = repS 'US-Windows rechnet mit "." / Metrisches Windows mit ","
nnenn = nnenn & help
'msgbox "++ " & nnenn
End If
Next
getKoor=nnenn
End Function
Function getPair(inLine)
sp1=instr(inLine,"(")
Wert=mid(inLine,1,sp1-1)
sp2=sp1
While (mid(inLine,sp2,1)<>")")
sp2=sp2+1
Wend
getPair=mid(inline,sp1,sp2-sp1+1)
'msgbox inLine & " # " & getPair
End Function
Function getVal(inLine)
sp1=instr(inLine," ")
Wert=mid(inLine,1,sp1-1)
sp2=sp1
While (mid(inLine,sp2,1)=" ")
sp2=sp2+1
Wend
getVal=mid(inLine,sp2)
End Function
Function splKoor(WPaar,xE,yE,mx,my)
i=len(WPaar)
yF=0
yE=0 'mil als default
xE=0
mx=0
my=0
While i>0
help=mid(WPaar,i,1)
'Einheit merken und abschneiden
If help="m" Then
If yF=0 Then
yE=1 'yE=1 -> mm yE=0 -> mil
Else
xE=1 'xE=1 -> mm ...
End If
i=i-2
Else
'Zahlenstring aufbauen + in my oder mx
If (help>="0" And help<="9") Or (help=",") Or (help="-") Or (help=".") Then
If yF=0 Then 'y-Wert
help = help & my
my = help
Else 'x-Wert
help = help & mx
mx = help
End If
Else
yF=1 'merken -> y-Wert ist abgearbeitet
End If
End If
i=i-1
Wend
'noch alle Werte in Mil umrechnen
If xE=1 Then
mx = mx / 0.0254
xE= 0
End If
If ye=1 Then
my= my / 0.0254
yE=0
End If
End Function
E-mail: 
info@telesys.ru
