'''Copyright 2010 Yaroslav Solyanikov (yaroslav1982@mail.ru, (8914)0317248)
'''http://zv.innovaterussia.ru/project/5425'''a3plotter.narod.ru
'''FORBIDDEN FOR COMMERCIAL USE AND DISTRIBUTION
'''If you wish to distribute this document, the macro code contained within this document, or modified copies, you may do so only under the terms of the Gnu Lesser General Public License (LGPL).
'''NO WARRANTY
'''This document and its code is offered for free AS IS with NO WARRANTY whatsoever. For more information, see the NO WARRANTY disclaimer in the Gnu Lesser General Public License.
'''The license document is available here. http://www.gnu.org/licenses/lgpl.html
Dim c As Color
Private Sub cmdA4_Click() ActiveDocument.Unit = cdrMillimeter
Dim sx As Double, sy As Double ActivePage.GetSize sx, sy MsgBox sx MsgBox sy
Exit Sub End Sub
Private Sub cmdButtons_Click() Open "main.ini" For Input As #1 Line Input #1, s
cmdCut.Caption = Parse(s, 1, vbTab) cmdCut.ControlTipText = Parse(s, 2, vbTab) Line Input #1, s
cmdLineScience.Caption = Parse(s, 1, vbTab) cmdLineScience.ControlTipText = Parse(s, 2, vbTab) Line Input #1, s
cmdLineY.Caption = Parse(s, 1, vbTab) cmdLineY.ControlTipText = Parse(s, 2, vbTab) Line Input #1, s
cmdGraph.Caption = Parse(s, 1, vbTab) cmdGraph.ControlTipText = Parse(s, 2, vbTab) Line Input #1, s
CommandButton6.Caption = Parse(s, 1, vbTab) CommandButton6.ControlTipText = Parse(s, 2, vbTab)
Line Input #1, s
cmdEditGraph.Caption = Parse(s, 1, vbTab)
cmdEditGraph.ControlTipText = Parse(s, 2, vbTab)
Line Input #1, s
cmdEditUnit.Caption = Parse(s, 1, vbTab)
cmdEditUnit.ControlTipText = Parse(s, 2, vbTab)
'Line Input #1, s
'cmdEditMap.Caption = Parse(s, 1, vbTab)
'cmdEditMap.ControlTipText = Parse(s, 2, vbTab)
'Line Input #1, s
'CommandButton8.Caption = Parse(s, 1, vbTab) 'CommandButton8.ControlTipText = Parse(s, 2, vbTab) 'Line Input #1, s
'txtPartitionY.Text = Parse(s, 1, vbTab) Close #1 End Sub
Private Sub cmdCDR_Click() ActiveDocument.Unit = cdrMillimeter
s = Parse(txtFileName.Text, 1, ".") s = Parse(txtFileName.Text, 1, "\")
s = InputBox("Enter the name for saved file (*.cdr):", "A3 Plotter", s) ActiveDocument.SaveAs txtPath.Text + "/" + s + ".cdr"
End Sub
Private Sub cmdColor_Click() Set c = New Color Dim b As Boolean With c
.RGBAssign 255, 255, 255 b =.UserAssignEx If b Then
If .Type <> cdrColorRGB Then .ConvertToRGB End If End With End Sub
Private Sub cmdConv_Click()
frmPaleomagConv.Show 0 End Sub
Private Sub cmdCounter_Click()
For Each p In ActiveSelection.Shapes p.Rotate -txtMR.Value
Next End Sub
Private Sub cmdCut_Click() On Error Resume Next Dim d As Document Dim sel As Shape, s As Shape
Dim x As Double, y As Double, Shift As Long Dim c As New Color Set d = ActiveDocument
Set sel = d.ActivePage.SelectShapesFromRectangle(-1000, -1000, 1000, 1000, True)
sel.Cut
End Sub
Private Sub cmdEditGraph_Click()
Shell "notepad " + txtFileName.Text, 1 End Sub
Private Sub cmdEditUnit_Click()
Shell "notepad " + txtSheet.Text, 1 End Sub
Private Sub cmdEnd_Click()
End End Sub
Private Sub cmdGIF_Click() ActiveDocument.Unit = cdrMillimeter
s = Parse(txtFileName.Text, 1, ".") s = Parse(txtFileName.Text, 1, "\") Dim sx As Double, sy As Double ActivePage.GetSize sx, sy ActiveLayer.CreateRectangle2 0, 0, sx, sy
s = InputBox("Enter the name for saved file (*.gif):", "A3 Plotter", s) s1 = s
s = txtPath.Text + "/" + s + ".gif" ActiveDocument.Export s, cdrGIF txtRecent.Text = s1 End Sub
Private Sub cmdGraphDialog_Click()
frmMiniGraph.Show 0
frmMiniGraph.txtFrameName.Text = txtSheet.Text End Sub
Private Sub cmdJPG_Click() ActiveDocument.Unit = cdrMillimeter
s = Parse(txtFileName.Text, 1, ".") s = Parse(txtFileName.Text, 1, "\")
s = InputBox("Enter the name for saved file (*.jpg):", "A3 Plotter", s) s = txtPath.Text + "/" + s + ".jpg" ActiveDocument.Export s, cdrJPEG
End Sub
Private Sub cmdLineScience_Click() Dim ssMnogoI(1000) As Shape Dim ssMnogoSign(1000) As Shape
ActiveDocument.Unit = cdrMillimeter Dim H, d, i As Single Dim i2, iFlag, iGraph As Long Dim sLine, sParse As String sParse = vbTab i2 =1
Dim crv2 As Curve
Set crv2 = CreateCurve(ActiveDocument) Dim s2 As Shape Dim sp2 As SubPath
Dim crv3 As Curve
Set crv3 = CreateCurve(ActiveDocument)
Dim s3 As Shape
Dim sp3 As SubPath
Dim curveflag As Long i =0 For j = 1 To nChar(lstScience.List(i + 1), ";") + 1
Dim sMatrix As String
sMatrix = lstScience.List(i + 1) + vbTab + lstScience.List(i + 2)
'''''''''MsgBox j
If Parse(lstScience.List(i + 1), j, ";") = "" Then Exit For
delenie = ValPoint(Parse(lstScience.List(i + 1), j, ";"))
d = Smart2(lstScience.List(i + 1), lstScience.List(i + 2), delenie) ''', True)
delenie = ValPoint(Parse(lstScience.List(i + 4), j, ";"))
H = Smart2(lstScience.List(i + 4), lstScience.List(i + 5), delenie)
H = 100
H = ValPoint(Parse(Parse(lstScience.List(i), 2, vbTab), 1, ";"))
x1 =0 '''ValPoint(Parse(Parse(lstScience.List(i), 3, vbTab), 1, ";")) y1 =0 '''ValPoint(Parse(Parse(lstScience.List(i), 3, vbTab), 2, ";")) x2 = ValPoint(Parse(Parse(lstScience.List(i), 3, vbTab), 1, ";")) y2 = ValPoint(Parse(Parse(lstScience.List(i), 3, vbTab), 2, ";"))
x3 = ValPoint(Parse(Parse(lstScience.List(i), 4, vbTab), 1, ";")) y3 = ValPoint(Parse(Parse(lstScience.List(i), 4, vbTab), 2, ";"))
strdel = Parse(lstScience.List(i), 5, vbTab) If strdel = "xA4" Then strdel = CStr(d) If strdel = "yA4" Then strdel = CStr(H)
If strdel = "x" Then strdel = Parse(lstScience.List(i + 1), j, ";") If strdel = "y" Then strdel = Parse(lstScience.List(i + 4), j, ";")
If (InStr(strdel, "000") + InStr(strdel, "999")) > 0 Then _
strdel = Format(Round(ValPoint(strdel), 4), "#########.#########")
strdel = Trim(strdel)
If Left(strdel, 1) = "." Then strdel = "0" + strdel
Dim curvebegan As Boolean If curvebegan = False Then
Set sp3 = crv3.CreateSubPath(d, H)
curvebegan = True End If sp3.AppendLineSegment d, H
Set crv2 = CreateCurve(ActiveDocument)
Set sp2 = crv2.CreateSubPath(d + x1, H + y1)
If d <> 0 And H <> 0 Then sp2.AppendLineSegment d + x2, H + y2
Set ssMnogoI(j) = ActiveLayer.CreateCurve(crv2)
If strdel <> "" And d <> 0 And H <> 0 Then Set _ ssMnogoSign(i)= ActiveLayer.CreateArtisticText(d + x3, _ H + y3, strdel, cdrRussian, cdrCharSetRussian, "Times New Roman", txtFontSize.Value) Next
Set s3 = ActiveLayer.CreateCurve(crv3) For j_real = 1 To j - 2
ssMnogoI(j_real).AddToSelection Next
Dim s5 As Shape
Set s5 = ActiveSelection.Group ActiveDocument.Unit = cdrPoint
s5.Outline.SetProperties ValPoint(txtFrameWidth.Text), , c ActiveDocument.Unit = cdrMillimeter End Sub
Private Sub cmdLineY_Click()
Dim ssMnogoI(1000) As Shape Dim ssMnogoSign(1000) As Shape
ActiveDocument.Unit = cdrMillimeter Dim H, d, i As Single Dim i2, iFlag, iGraph As Long Dim sLine, sParse As String sParse = vbTab i2 =1
Dim crv2 As Curve
Set crv2 = CreateCurve(ActiveDocument) Dim s2 As Shape Dim sp2 As SubPath
Dim crv3 As Curve
Set crv3 = CreateCurve(ActiveDocument)
Dim s3 As Shape
Dim sp3 As SubPath
Dim curveflag As Long
i =0
For j = 1 To nChar(lstScience.List(i + 4), ";") + 1
Dim sMatrix As String
sMatrix = lstScience.List(i + 4) + vbTab + lstScience.List(i + 5)
If Parse(lstScience.List(i + 4), j, ";") = "" Then Exit For
delenie = ValPoint(Parse(lstScience.List(i + 1), j, ";"))
d = Smart2(lstScience.List(i + 1), lstScience.List(i + 2), delenie) ''', True)
d = ValPoint(Parse(Parse(lstScience.List(i + 3), 2, vbTab), 1, ";"))
delenie = ValPoint(Parse(lstScience.List(i + 4), j, ";"))
H = Smart2(lstScience.List(i + 4), lstScience.List(i + 5), delenie) ''')), True) x1 = ValPoint(Parse(Parse(lstScience.List(i + 3), 3, vbTab), 1, ";")) y1 = ValPoint(Parse(Parse(lstScience.List(i + 3), 3, vbTab), 2, ";")) x2 = ValPoint(Parse(Parse(lstScience.List(i + 3), 3, vbTab), 3, ";")) y2 = ValPoint(Parse(Parse(lstScience.List(i + 3), 3, vbTab), 4, ";")) x3 = ValPoint(Parse(Parse(lstScience.List(i + 3), 4, vbTab), 1, ";")) y3 = ValPoint(Parse(Parse(lstScience.List(i + 3), 4, vbTab), 2, ";"))
strdel = Parse(lstScience.List(i + 3), 5, vbTab)
If strdel = "xA4" Then strdel = CStr(d)
If strdel = "yA4" Then strdel = CStr(H)
If strdel = "x" Then strdel = Parse(lstScience.List(i + 1), j, ";")
If strdel = "y" Then strdel = Parse(lstScience.List(i + 4), j, ";")
If (InStr(strdel, "000") + InStr(strdel, "999")) > 0 Then _
strdel = Format(Round(ValPoint(strdel), 4), "#########.#########")
strdel = Trim(strdel)
If Left(strdel, 1) = "." Then strdel = "0" + strdel
''''''''''MsgBox Str(d) + "~" + Str(h)
Set crv2 = CreateCurve(ActiveDocument)
Set sp2 = crv2.CreateSubPath(d + x1, H + y1)
'''''''''''''''''''If (d + x2) <> 0 And h <> 0 Then
sp2.AppendLineSegment d + x2, H + y2
Dim curvebegan As Boolean
If curvebegan = False Then
Set sp3 = crv3.CreateSubPath(d, H)
curvebegan = True End If sp3.AppendLineSegment d, H
Set ssMnogoI(j) = ActiveLayer.CreateCurve(crv2)
'''If strdel <> "" And d <> 0 And h <> 0
If strdel <> "" Then Set _
ssMnogoSign(i)= ActiveLayer.CreateArtisticText(d + x3, _
H + y3, strdel, cdrRussian, cdrCharSetRussian, "Times New Roman", txtFontSize.Value) Next
Set s3 = ActiveLayer.CreateCurve(crv3) For j_real = 1 To j - 1
ssMnogoI(j_real).AddToSelection Next
Dim s5 As Shape
Set s5 = ActiveSelection.Group ActiveDocument.Unit = cdrPoint
s5.Outline.SetProperties ValPoint(txtFrameWidth.Text), , c ActiveDocument.Unit = cdrMillimeter
End Sub
Private Sub cmdload_Click()
Dim sPath As String
lstSubFolders.Clear
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each PossibleFile In FSO.GetFolder(".").SubFolders
lstSubFolders.AddItem (PossibleFile.Name)
sPath = FSO.GetFolder(".").Path
txtPath.Text = sPath Next
End Sub
Private Sub cmdGraph_Click() ActiveDocument.Unit = cdrMillimeter '''On Error GoTo qwe:
Dim snote As String
ActiveDocument.Unit = cdrMillimeter
''''''''''''''''''''''''''''''''''''''Call IniMinMax
Dim H, d, i As Single
Dim i2, iFlag, iGraph As Long
Dim sLine, sParse As String
sParse = vbTab
If frmMain.txtFileName.Text = "" Then Exit Sub
Open frmMain.txtFileName.Text For Input As #1
i2 =1
Dim crv As Curve
Set crv = CreateCurve(ActiveDocument)
Dim s As Shape
Dim sp As SubPath
Dim curveflag As Long
'''============================================
Do Until EOF(1)
Do Until EOF(1)
Do Until EOF(1)
Line Input #1, sLine: i2 = i2 +1
If divisible(i2, ValPoint(txtDeplete.Text)) = True Then Exit Do Loop
If InStr(sLine, "!!!") = 0 Then Exit Do Loop
i =0 ''''''''''For i = 0 To lstScience.ListCount - 1 Step 10 col = ValPoint(Parse(lstScience.List(i), 1, vbTab)) srav = ValPoint(Parse(sLine, col, vbTab)) Dim t1, t3, t5, t7 As Single t1 = ValPoint(txtFromX.Text) t3 = ValPoint(txtToX.Text) t5 = ValPoint(txtFromX2.Text) t7 = ValPoint(txtToX2.Text) part = ValPoint(txtXdivision.Text) / 1000000
d0 = Smart2(lstScience.List(1), lstScience.List(2), srav) col = ValPoint(Parse(lstScience.List(3), 1, vbTab)) srav = ValPoint(Parse(sLine, col, vbTab)) t1 = ValPoint(txtFromY.Text) t3 = ValPoint(txtToY.Text) t5 = ValPoint(txtFromY2.Text) t7 = ValPoint(txtToY2.Text) part = ValPoint(txtYdivision.Text) / 1000000
h0 = Smart2(lstScience.List(4), lstScience.List(5), srav)
If d0 <> 0 And h0 <> 0 Then d = d0: H = h0 snote = Parse(sLine, note, sParse) ''': h = Val(Parse(sLine, NY, sParse)) Dim curvebegan As Boolean If curvebegan = False And d <> 0 And H <> 0 Then
'''Set sp = crv.CreateSubPath(shiftD + d / koefD, shiftH + h / koefH) Set sp = crv.CreateSubPath(d, H) curvebegan = True End If iFlag =0
'If chkMidTrue.Value = True Then
'If midTrue(d0, ValPoint(txtFromX2), ValPoint(txtToX2)) = False _ ' Or midTrue(h0, ValPoint(txtFromY2), ValPoint(txtToY2)) = False _ ' Then iFlag = 1 'End If If d <> 0 And H <> 0 And iFlag = 0 Then
If d <> 0 And H <> 0 Then sp.AppendLineSegment d, H dbm = d: hbm = H End If
If i2 > ValPoint(txtModD.Text) Then MsgBox i2: Exit Do If InStr(snote, "---") > 0 Then curveflag = 1: Exit Do Loop
Close #1
If chkClosed.Value = True Then sp.Closed = True
Set s = ActiveLayer.CreateCurve(crv)
If chkClosed.Value = True Then s.Fill.ApplyUniformFill c
ActiveDocument.Unit = cdrPoint
s.Outline.SetProperties ValPoint(txtLineWidth.Text), , c qwe:
ActiveDocument.Unit = cdrMillimeter
End Sub
Private Sub cmdMarkers_Click() Dim iFlag As Long
'''''''''''''''''''''''''''''''''''''''''''''''' Dim ssMnogo(1000) As Shape Dim ssMnogoI(1000) As Shape Dim ssMnogoSign(1000) As Shape
Dim ellipses(0 To 1000) As Shape
Dim s As Shape
Set s = ActiveDocument.Selection
'''s.Copy
If s.Shapes.Count = 0 Then
MsgBox "No Object Selected"
Exit Sub End If
'''MsgBox 111 sParse = vbTab
Open frmMain.txtFileName.Text For Input As #1 i2 =1
Dim crv As Curve
Set crv = CreateCurve(ActiveDocument) Dim sp As SubPath Dim curveflag As Long
'''============================================
Do Until EOF(1)
Do Until EOF(1)
Do Until EOF(1)
Line Input #1, sLine: i2 = i2 +1
If divisible(i2, ValPoint(txtDeplete.Text)) = True Then Exit Do Loop
If InStr(sLine, "!!!") = 0 Then Exit Do Loop
i =0 ''''''''''For i = 0 To lstScience.ListCount - 1 Step 10
col = ValPoint(Parse(lstScience.List(i), 1, vbTab)) srav = ValPoint(Parse(sLine, col, vbTab)) Dim t1, t3, t5, t7 As Single t1 = ValPoint(txtFromX.Text) t3 = ValPoint(txtToX.Text) t5 = ValPoint(txtFromX2.Text) t7 = ValPoint(txtToX2.Text) part = ValPoint(txtXdivision.Text) / 1000000
d0 = Smart2(lstScience.List(1), lstScience.List(2), srav)
col = ValPoint(Parse(lstScience.List(3), 1, vbTab)) srav = ValPoint(Parse(sLine, col, vbTab)) t1 = ValPoint(txtFromY.Text) t3 = ValPoint(txtToY.Text) t5 = ValPoint(txtFromY2.Text) t7 = ValPoint(txtToY2.Text) part = ValPoint(txtYdivision.Text) / 1000000
h0 = Smart2(lstScience.List(4), lstScience.List(5), srav)
If d0 <> 0 And h0 <> 0 Then d = d0: H = h0 iFlag =0
If (d <> 0) And (H <> 0) And (iFlag = 0) Then Set ssMnogo(i2) = s.Duplicate
ddd = ValPoint(Parse(Parse(lstScience.List(i + 3), 2, vbTab), 1, ";")) hhh = ValPoint(Parse(Parse(lstScience.List(i), 2, vbTab), 1, ";")) If chkXmark.Value = True Then
If (d - ddd) <> 0 Then s.SizeWidth = Abs(d - ddd) s.PositionX = d - s.SizeWidth ''dd '''d0 ''dd ''- s.SizeWidth If d < ddd Then s.PositionX = ddd - s.SizeWidth '''s.PositionX = s.PositionX - s.SizeWidth
Else
s.PositionX = d - s.SizeWidth /2 '''- s.SizeWidth '''d0 ''dd ''-
s.SizeWidth
s.SizeWidth
End If
If chkYmark.Value = True Then
If (H - hhh) <> 0 Then s.SizeHeight = Abs(H - hhh)
s.PositionY = H '''hh '''d0 ''dd ''- s.SizeWidth
If H < hhh Then s.PositionY = hhh Else
s.PositionY = H + s.SizeHeight /2 '''.SizeHeight / 2 '''d0 ''dd ''End If dbm = d: hbm = H
End If
Loop
'''============================================
Close #1
Set crv = Nothing Set s = Nothing Set sp = Nothing End Sub
Private Sub cmdMR_Click()
frmMiniMR.Show (vbnomodal) End Sub
Private Sub cmdNextA4_Click()
If lstSubFiles.ListIndex < (lstSubFiles.ListCount - 1) Then lstSubFiles.ListIndex = lstSubFiles.ListIndex +1
End Sub
Private Sub cmdNextIni_Click()
If lstSubText.ListIndex < (lstSubText.ListCount - 1) Then lstSubText.ListIndex = lstSubText.ListIndex +1 End Sub
Private Sub cmdRefresh_Click() s = lstSubFolders.Text
lstSubFiles.Clear
Set FSO = CreateObject("Scripting.FileSystemObject") For Each PossibleFile In FSO.GetFolder(s).files lstSubFiles.AddItem (PossibleFile.Name) Next End Sub
Private Sub cmdS1_Click()
sFile = txtSubFolder.Text + "\" + lstSubText.Text End Sub
Private Sub cmdTexts_Click() Open "sizes.ini" For Input As #1
Line Input #1, s
txtFrameWidth.Text = Parse(s, 1, vbTab)
Line Input #1, s
txtLineWidth.Text = Parse(s, 1, vbTab)
Line Input #1, s
txtFontSize.Text = Parse(s, 1, vbTab)
Line Input #1, s
txtModD.Text = Parse(s, 1, vbTab)
Line Input #1, s
txtDeplete.Text = Parse(s, 1, vbTab)
'Line Input #1, s
'txtPartitionY.Text = Parse(s, 1, vbTab) Close #1 End Sub
Private Sub CommandButton6_Click()
frmMiniJPG.Show 0 End Sub
Private Sub lstGraphs_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) lstGraphs_Click
End Sub
Private Sub lstSheets_Click() lstGraphs.Clear
Open lstSheets.Text For Input As #1 ' Do Until EOF(1)
Line Input #1, s
If InStr(s, "!!!") = 0 Then lstGraphs.AddItem s Loop Close #1
txtSheet.Text = lstSheets.Text
End Sub
Private Sub lstSubFiles_Click()
Dim s, sFile As String
sFile = txtSubFolder.Text + "\" + lstSubFiles.Text
If (InStr(sFile, "border") + InStr(sFile, "marker")) > 0 Then
lst10.Clear
Open sFile For Input As #1
Do Until EOF(1)
Line Input #1, s
If InStr(s, "!!!") = 0 Then lst10.AddItem s Loop Close #1
End If
If InStr(sFile, ".xls") > 0 Then txtFileName.Text = txtSubFolder.Text + "\" + lstSubFiles.Text: If chkAutoGen.Value = True Then Call cmdGraph_Click
If InStr(sFile, ".txt") > 0 Then txtSheet.Text = txtSubFolder.Text + "\" + lstSubFiles.Text ''': If chkAutoGen.Value = True Then Call cmdGraph_Click
End Sub
Private Sub lstSubFolders_Click() s = lstSubFolders.Text
txtSubFolder.Text = s '''lstSubFolders.Text lstSubFiles.Clear
Set FSO = CreateObject("Scripting.FileSystemObject") For Each PossibleFile In FSO.GetFolder(s).files If (InStr(PossibleFile.Name, ".xls") * _
InStr(PossibleFile.Name, ".xls")) > 0 Then _
lstSubFiles.AddItem (PossibleFile.Name) Next
lstSubText.Clear
Set FSO = CreateObject("Scripting.FileSystemObject") For Each PossibleFile In FSO.GetFolder(s).files If (InStr(PossibleFile.Name, ".txt") * _
InStr(PossibleFile.Name, ".txt")) > 0 Then _ lstSubText.AddItem (PossibleFile.Name) Next
If lstSubText.ListCount > 0 Then lstSubText.ListIndex = 0:
'''''''''''''''''txtSheet.Text = lstSubText.Text Call lstSubText_Click End If End Sub
Private Sub lstSubText_Change()
Call lstSubText_Click End Sub
Private Sub lstSubText_Click() Dim s, sFile As String
sFile = txtSubFolder.Text + "\" + lstSubText.Text
If (InStr(sFile, "border") + InStr(sFile, "marker")) > 0 Then
lst10.Clear
Open sFile For Input As #1
Do Until EOF(1)
Line Input #1, s
If InStr(s, "!!!") = 0 Then lst10.AddItem s Loop Close #1 End If
If InStr(sFile, ".txt") > 0 Then txtSheet.Text = txtSubFolder.Text + "\" + lstSubText.Text ''': If chkAutoGen.Value = True Then Call cmdGraph_Click
End Sub
Private Sub lstSubText_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Call lstSubText_Click End Sub
Private Sub txtSheet_Change() lstScience.Clear
If txtSheet.Text = "" Then Exit Sub Open txtSheet.Text For Input As #1 Do Until EOF(1)
Line Input #1, s
If InStr(s, "!!!") = 0 Then lstScience.AddItem s '''Parse(s, 3, vbTab) Loop
Close #1 End Sub
Private Sub UserForm_Activate()
Call cmdload_Click
Call cmdButtons_Click
Call cmdTexts_Click End Sub
'''Copyright 2010 Yaroslav Solyanikov (yaroslav1982@mail.ru, (8914)0317248)
'''http://zv.innovaterussia.ru/project/5425
'''a3plotter.narod.ru
'''FORBIDDEN FOR COMMERCIAL USE AND DISTRIBUTION
'''If you wish to distribute this document, the macro code contained within this document,
or modified copies, you may do so only under the terms of the Gnu Lesser General Public
License (LGPL).
'''NO WARRANTY
'''This document and its code is offered for free AS IS with NO WARRANTY whatsoever. For
more information, see the NO WARRANTY disclaimer in the Gnu Lesser General Public License.
'''The license document is available here. http://www.gnu.org/licenses/lgpl.html
Private Sub cmdDivideX_Click()
txtXstring = divideX(ValPoint(txtFromX.Text), ValPoint(txtToX.Text), ValPoint(
txtXdivision.Text))
txtXstring2 = divideX(ValPoint(txtFromX2.Text), ValPoint(txtToX2.Text), ValPoint(
txtXdivision.Text))
End Sub
Private Sub cmdDivideY_Click()
txtYstring = divideX(ValPoint(txtFromY.Text), ValPoint(txtToY.Text), ValPoint(
txtYdivision.Text))
txtYstring2 = divideX(ValPoint(txtFromY2.Text), ValPoint(txtToY2.Text), ValPoint(
txtYdivision.Text))
End Sub
Private Sub cmdRecord_Click()
Dim s As String
Open "frame.txt" For Input As #2
Open txtFrameName.Text For Output As #1
Line Input #2, s
Print #1, s
Print #1, txtNX.Text + vbTab + txtOXremoval.Text + vbTab + txtOXLenStrokes.Text + _
vbTab + txtOXLabelsRemoval.Text + vbTab + txtOXLabelsView.Text + vbTab +
txtOXComment.Text
Line Input #2, s
Print #1, s
Print #1, txtXstring.Text
Line Input #2, s
Print #1, s
Print #1, txtXstring2.Text
Line Input #2, s
Print #1, s
Print #1, txtNY.Text + vbTab + txtOYremoval.Text + vbTab + txtOYLenStrokes.Text + _
vbTab; txtOYLabelsRemoval.Text + vbTab + txtOYLabelsView.Text + vbTab +
txtOYComment.Text
Line Input #2, s
Print #1, s
Print #1, txtYstring.Text
Line Input #2, s
Print #1, s
Print #1, txtYstring2.Text
Close #1
Close #2
End Sub
Private Sub cmdload_Click()
If frmMain.lstScience.ListCount = 0 Then Exit Sub
ActiveDocument.Unit = cdrMillimeter
col = ValPoint(Parse(frmMain.lstScience.List(i), 1, vbTab))
'''srav = ValPoint(Parse(sLine, col, vbTab))
'''MsgBox srav
d0 = frmMain.lstScience.List(i + 1) '''SmartUnit(frmMain.lstScience.List(i +
1), frmMain.lstScience.List(i + 2), srav)
d1 = frmMain.lstScience.List(i + 2) ''' SmartUnit(frmMain.lstScience.List(i
+ 2), frmMain.lstScience.List(i + 2), srav)
'''''''srav = SmartStrings((Parse(lstScience.List(i + 3), 1, vbTab)), sLine,
Parse(Parse(lstScience.List(i + 3), 2, vbTab), 2, ";"))
'''MsgBox
txtNX = col
txtXstring = d0
txtXstring2 = d1
txtOXremoval = Parse(frmMain.lstScience.List(i), 2, vbTab)
txtOXLenStrokes = Parse(frmMain.lstScience.List(i), 3, vbTab)
txtOXLabelsRemoval = Parse(frmMain.lstScience.List(i), 4, vbTab)
txtOXLabelsView = Parse(frmMain.lstScience.List(i), 5, vbTab)
txtOXComment = Parse(frmMain.lstScience.List(i), 6, vbTab)
'txtFromX2 = d0
'txtFromX = d1
col = ValPoint(Parse(frmMain.lstScience.List(i + 3), 1, vbTab))
'''srav = ValPoint(Parse(sLine, col, vbTab))
'''srav = SmartStrings((Parse(lstScience.List(i + 3), 1, vbTab)), sLine,
Parse(Parse(lstScience.List(i + 3), 2, vbTab), 1, ";"))
'''MsgBox srav
h0 = frmMain.lstScience.List(i + 4) '''SmartUnit(frmMain.lstScience.List(i +
4), frmMain.lstScience.List(i + 5), srav)
h1 = frmMain.lstScience.List(i + 5) '''SmartUnit(frmMain.lstScience.List(i +
4), frmMain.lstScience.List(i + 5), srav)
txtNY = col
txtYstring = h0
txtYstring2 = h1
txtOYremoval = Parse(frmMain.lstScience.List(i + 3), 2, vbTab)
txtOYLenStrokes = Parse(frmMain.lstScience.List(i + 3), 3, vbTab)
txtOYLabelsRemoval = Parse(frmMain.lstScience.List(i + 3), 4, vbTab)
txtOYLabelsView = Parse(frmMain.lstScience.List(i + 3), 5, vbTab)
txtOYComment = Parse(frmMain.lstScience.List(i + 3), 6, vbTab)
''MsgBox h0
txtXdivision = nChar(txtXstring.Text, ";")
txtYdivision = nChar(txtYstring.Text, ";")
ActiveDocument.Unit = cdrMillimeter
txtFromX = Parse(txtXstring, 1, ";")
txtToX = Parse(txtXstring, ValPoint(txtXdivision.Text) + 1, ";")
txtFromY = Parse(txtYstring, 1, ";")
txtToY = Parse(txtYstring, ValPoint(txtYdivision.Text) + 1, ";")
txtFromX2 = Parse(txtXstring2, 1, ";")
txtToX2 = Parse(txtXstring2, ValPoint(txtXdivision.Text) + 1, ";")
txtFromY2 = Parse(txtYstring2, 1, ";")
txtToY2 = Parse(txtYstring2, ValPoint(txtYdivision.Text) + 1, ";")
End Sub
Private Sub cmdStr2Txt_Click()
''txtAxis.Text = "qw" + vbCrLf + "er"
End Sub
Private Sub cmdStr2TxtX_Click()
chkY.Value =0
txtAxis.Text = ""
i =1
txtAxis.Text = Parse(txtXstring.Text, i, ";")+ " " + Parse(txtXstring2.Text, i, ";")
For i = 2 To ValPoint(txtXdivision.Text) + 1
txtAxis.Text = txtAxis.Text + vbCrLf + Parse(txtXstring.Text, i, ";")+ " " + Parse(
txtXstring2.Text, i, ";")
Next
End Sub
Private Sub cmdStr2TxtY_Click()
chkY.Value =1
txtAxis.Text = ""
i =1
txtAxis.Text = Parse(txtYstring.Text, i, ";")+ " " + Parse(txtYstring2.Text, i, ";")
For i = 2 To ValPoint(txtYdivision.Text) + 1
txtAxis.Text = txtAxis.Text + vbCrLf + Parse(txtYstring.Text, i, ";")+ " " + Parse(
txtYstring2.Text, i, ";")
Next
End Sub
Private Sub cmdTxt2Str_Click()
'''MsgBox nChar(txtAxis.Text, vbCr)
s = FindReplace(txtAxis.Text, vbCrLf, ";")
" ; "
" ; "
s = FindReplace(s, vbTab, " ")
n = nChar(s, ";")
''news
news = ""
news1 = ""
news2 = ""
For i = 1 To n
news = Parse(s, i, ";")
If Trim(Parse(news, 1, " ")) <> "" Then news1 = news1 + Trim(Parse(news, 1, " ")) +
If Trim(Parse(news, 2, " ")) <> "" Then news2 = news2 + Trim(Parse(news, 2, " ")) +
Next
news = Parse(s, n + 1, ";")
news1 = news1 + Trim(Parse(news, 1, " "))
news2 = news2 + Trim(Parse(news, 2, " "))
i = Len(news1)
If Right(news1, 1) = ";" Then news1 = Left(news1, i - 1)
i = Len(news2)
If Right(news2, 1) = ";" Then news2 = Left(news2, i - 1)
If chkY.Value = 0 Then
txtXstring = news1: txtXstring2 = news2:
txtXdivision = nChar(news1, ";")+1
txtFromX = Parse(news1, 1, ";")
txtToX = Parse(news1, ValPoint(txtXdivision), ";")
txtFromX2 = Parse(news2, 1, ";")
txtToX2 = Parse(news2, ValPoint(txtXdivision), ";")
End If
If chkY.Value = True Then
txtYstring = news1: txtYstring2 = news2:
txtYdivision = nChar(news2, ";")+1
txtFromY = Parse(news1, 1, ";")
txtToY = Parse(news1, ValPoint(txtYdivision), ";")
txtFromY2 = Parse(news2, 1, ";")
txtToY2 = Parse(news2, ValPoint(txtYdivision), ";")
End If
''MsgBox news
''MsgBox news1
''MsgBox news2
End Sub
Private Sub cmdTxt2StrX_Click()
'''MsgBox nChar(txtAxis.Text, vbCr)
s = FindReplace(txtAxis.Text, vbCrLf, ";")
n = nChar(s, ";")
''news
news = ""
news1 = ""
news2 = ""
For i = 1 To n
news = Parse(s, i, ";")
news1 = news1 + Trim(Parse(news, 1, " ")) + ";"
news2 = news2 + Trim(Parse(news, 2, " ")) + ";"
Next
news = Parse(s, n + 1, ";")
news1 = news1 + Trim(Parse(news, 1, " "))
news2 = news2 + Trim(Parse(news, 2, " "))
End Sub
Private Sub CommandButton1_Click()
MsgBox GetBetw("qwe/8/rty.m.xls", "/8/", ".m.")
End Sub
Private Sub txtFrameName_Change()
End Sub
Private Sub txtFromY2_Change()
'''MsgBox txtFromY2.Text
txtOXremoval.Text = txtFromY2.Text
End Sub
Private Sub txtFromX2_Change()
'''MsgBox txtFromX2.Text
txtOYremoval.Text = txtFromX2.Text
End Sub
Private Sub txtOYremoval_Change()
End Sub
Private Sub UserForm_Activate()
Call cmdload_Click
End Sub
Private Sub UserForm_Click()
End Sub
Function GetBetw(ByVal qwerty As String, ByVal after As String, ByVal before As String)
i = InStr(qwerty, after)
l = Len(qwerty)
j = Len(after)
s = Right(qwerty, l - i - j + 1)
'''MsgBox s
i = InStr(s, before)
l = Len(s)
j = Len(before)
s = Left(s, i - 1)
GetBetw = s
End Function
'''Copyright 2010 Yaroslav Solyanikov (yaroslav1982@mail.ru, (8914)0317248)
'''http://zv.innovaterussia.ru/project/5425
'''a3plotter.narod.ru
'''FORBIDDEN FOR COMMERCIAL USE AND DISTRIBUTION
'''If you wish to distribute this document, the macro code contained within this document,
or modified copies, you may do so only under the terms of the Gnu Lesser General Public
License (LGPL).
'''NO WARRANTY
'''This document and its code is offered for free AS IS with NO WARRANTY whatsoever. For
more information, see the NO WARRANTY disclaimer in the Gnu Lesser General Public License.
'''The license document is available here. http://www.gnu.org/licenses/lgpl.html
Sub Main()
CreateDocument
frmMain.Show (0)
End Sub
Function proportion(ByVal x1 As Single, ByVal x2 As Single, ByVal i As Single, ByVal min As
Single, ByVal max As Single) As Single
If x1 = x2 Then proportion = min: Exit Function
''''!!! min
part =(i - x1)/(x2 - x1)
proportion =(max - min)* part + min
End Function
Function partition(ByVal x As Single, ByVal price As Single) As Single
If price = 0 Then partition = 0: Exit Function
partition = Int((x + price / 2) / price) * price
End Function
Function midTrue(ByVal x, ByVal min, ByVal max As Single) As Boolean
midTrue = x > min And x < max Or x > max And x < min
End Function
Function divisible(ByVal x, ByVal y) As Boolean
If x > y Then maxi = x: mini = y Else maxi = y: mini = x
test = maxi - mini *(maxi \ mini)
If test = 0 Then divisible = True Else divisible = False
End Function
Function lowest(ByVal min As Single, ByVal max As Single) As Single
delta = Abs(max - min) / 10000
If max = min Then lowest = 0: Exit Function
rd =1
Do
If rd <= delta Then
lowest = rd:
Exit Function
Else
rd = rd / 10
End If
Loop
End Function
Function FindReplace(ByVal qwerty, ByVal find, ByVal replace As String) As String
'''midTrue = x > min And x < max Or x > max And x < min
Dim s, symb As String
For i = 1 To Len(qwerty)
symb = Mid(qwerty, i, 1)
many = Mid(qwerty, i, Len(find))
If many = find Then
many = replace: i = i + Len(find) - 1: s = s + replace
Else
s = s + symb
End If
Next
FindReplace = s
End Function
Function StrComma(ByVal qwerty As String, Optional ByVal bComma As Boolean = True) As String
If bComma = False Then
StrComma = FindReplace(qwerty, ",", ".")
Else
StrComma = FindReplace(qwerty, ".", ",")
End If
End Function
Function ValPoint(ByVal qwerty As String) As Single
ValPoint = Val(FindReplace(qwerty, ",", "."))
End Function
Function Xmap(ByVal qwerty As Single, ByVal x1 As Single, ByVal x2 As Single) As Single
If (x2 - x1) < 360 Then Xmap = qwerty: Exit Function
If qwerty > x2 Then Xmap = Xmap(qwerty - 360, x1, x2): Exit Function
If qwerty < x1 Then Xmap = Xmap(qwerty + 360, x1, x2): Exit Function
Xmap = qwerty
End Function
Sub guidelineX(ByVal x As Long)
ActiveLayer.CreateGuide x, -900, x, 900
End Sub
Sub guidelineY(ByVal y As Long)
ActiveLayer.CreateGuide -900, y, 900, y
End Sub
Function str2tab(ByVal qwerty As String)
s = qwerty '''''''''''txtStr2Tab.Text
'''''''''''''''''''''''''''''Line Input #1, s
s4 = ""
Do
s1 = Trim(s)
s2 = Parse(s1, 1, " ")
FappendN "qwe.txt", s2
If s1 = s2 Then sum = sum + s2: str2tab = sum: Exit Function
i = Len(s1)- Len(s2)
s3 = Right(s1, i)
FappendN "qwe.txt", s3
s = s3
sum = sum + s2 + vbTab
FappendN "qwe.txt", s3
'If s1 = s2 Then s4 = s4 + s2: Exit Do
's = Parse(s1, 2, s2)
's4 = s4 + s2 + vbTab
Loop
'''''''''''''''''''''Print #2, s4
''''MsgBox s4
''str2tab = s4
End Function
Function divideX(ByVal x1 As Single, ByVal x2 As Single, ByVal n As Long) As String
If n = 0 Or x1 = x2 Then Exit Function
dx =(x2 - x1)/ n
Dim s As String
Dim xN As Single
For xN = x1 To x2 Step dx
If xN >= x2 And dx > 0 Or xN <= x2 And dx < 0 Then Exit For
s = s + Trim(Str(xN)) + ";"
'''If xN = x2 Then Exit For
'''If xN <> x2 Then s = s + ";"
Next
'''MsgBox xN
s = s + Trim(Str(x2))
'''MsgBox s
divideX = s
End Function
'''Copyright 2010 Yaroslav Solyanikov (yaroslav1982@mail.ru, (8914)0317248)
'''http://zv.innovaterussia.ru/project/5425
'''a3plotter.narod.ru
'''FORBIDDEN FOR COMMERCIAL USE AND DISTRIBUTION
'''If you wish to distribute this document, the macro code contained within this document,
or modified copies, you may do so only under the terms of the Gnu Lesser General Public
License (LGPL).
'''NO WARRANTY
'''This document and its code is offered for free AS IS with NO WARRANTY whatsoever. For
more information, see the NO WARRANTY disclaimer in the Gnu Lesser General Public License.
'''The license document is available here. http://www.gnu.org/licenses/lgpl.html
Option Explicit
Function Parse(ByVal sString As String, ByVal iReq As Integer, ByVal sDelim As String) As
String
Dim sSt As String, iCnt As Integer, iPos As Integer
If Len(sDelim) = 0 Then sDelim = ","
' Append sDelim if needed
If Right(sString, Len(sDelim)) <> sDelim Then
sSt = sString & sDelim
Else
sSt = sString
End If
If iReq = 0 Then
iPos = InStr(sSt, sDelim)
Do While iPos <> 0
iCnt = iCnt +1
iPos = InStr(iPos + 1, sSt, sDelim)
Loop
Parse$ = CStr(iCnt)
Else
For iCnt = 1 To iReq
iPos = InStr(sSt, sDelim)
If iPos Then
If iCnt = iReq Then ' Requested string
Parse$ = Left$(sSt, iPos - 1)
Exit For
End If
If iPos = Len(sSt) Then ' No string left
Parse$ = ""
Exit For
End If
sSt = Mid$(sSt, iPos + Len(sDelim))
Else
Parse$ = sSt
Exit For
End If
Next iCnt
End If
End Function
Public Function Finput(ByVal sName As String) As String
Dim filenumber
filenumber = FreeFile
Open sName For Input As #filenumber
Input #filenumber, Finput
Close #filenumber
End Function
Public Function Foutput(ByVal sName As String, ByVal sText As String) As Long
Dim filenumber
filenumber = FreeFile
Open sName For Output As #filenumber
Print #filenumber, sText
Close #filenumber
End Function
Public Function Fappend(ByVal sName As String, ByVal sText As String) As Long
Dim filenumber
filenumber = FreeFile
Open sName For Append As #filenumber
Print #filenumber, sText;
Close #filenumber
End Function
Public Function FappendN(ByVal sName As String, ByVal sText As String) As Long
Dim filenumber
filenumber = FreeFile
Open sName For Append As #filenumber
Print #filenumber, sText
Close #filenumber
End Function