| [Dmaths german users] gdmath-implementierungen |
[ Thread Index | Date Index | More dmaths.org/users-de Archives ]
|
Hallo, im Rahmen der Gdmath-Tools Multiplikation- bzw. Divisionsaufgabe habe ich eine horizontale Variante programmiert. Bei der Division führe eine Rechnung wie 0,001/6 zu einem Fehler - ist nun beseitigt. Ergänzend dazu: 1) OooGdmaths.Gdmaths, Sub TraceLigneGroupe: Der übergebene String "position" kann auch den Wert "t" annehmen. Das nutze ich bei der Multiplikation, damit der untere Strich die gleiche Länge wie der obere hat. 2) OooGdmaths.AdditionCode, Sub DimensionTexte: Folgende Zeilen hinzugefügt: xShape.Text.TextLeftDistance=0 xShape.Text.TextRightDistance=0 Dadurch werden die Ziffern in den Rechenaufgaben enger zusammen geschrieben. Ich würde gern eure Meinung dazu erfahren. Natürlich auch, wenn es Unsinn ist oder Fehler auftreten. Gruß, Michael |
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script"; script:name="AdditionCode" script:language="StarBasic">'OOoGdmath
'Copyright (C) 2005-2009 Gilles Daurat
'This program is free software; you can redistribute it and/or
'modify it under the terms of the GNU General Public License
'as published by the Free Software Foundation; either version 2
'of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
Option Explicit
Dim oAdditionForm as Object
Sub Main
oAdditionForm = LoadDialog("OOoGdmath","AdditionForm")
ChangeTitreDialog(oAdditionForm)
' RestaureForm(oAdditionForm)
oAdditionForm.Execute()
End Sub
Private Sub AdditionCode_CheckBox1_Click()
oAdditionForm.Model.TextBox3.Enabled = oAdditionForm.Model.CheckBox1.State
End Sub
Private Sub AdditionCode_CommandButton1_Click()
oAdditionForm.EndExecute()
SauveForm(oAdditionForm)
Operation(oAdditionForm.Model.TextBox1.Text, oAdditionForm.Model.CheckBox1.State)
End Sub
Private Sub AdditionCode_CommandButton2_Click()
oAdditionForm.EndExecute()
End Sub
Private Sub AdditionCode_Image1_Click()
ChangeCouleur oAdditionForm.Model.Image1
End Sub
Private Sub AdditionCode_TextBox3_Change()
oAdditionForm.Model.TextBox3.Text = Left$(oAdditionForm.Model.TextBox3.Text, 1)
End Sub
Sub InsereAdditionSoustractionSexa(tableau$(), Operation)
Dim Resultat$(3)
Dim l,h, retenue, i, resnum, terme1, terme2, resul
Dim Shapes as Object
InitialiseDessin(False)
Shapes=InitialiseGroupe()
DimensionTexte "8",12,l,h
Select Case Operation
Case "+"
retenue = 0
For i = 2 To 0 Step -1
tableau$(0,i)=right("00" & tableau$(0,i),2)
tableau$(1,i)=right("00" & tableau$(1,i),2)
resnum = Val(tableau$(0, i)) + Val(tableau$(1, i)) + retenue
If resnum > 59 Then
resnum = resnum - 60
retenue = 1
else
retenue = 0
End If
Resultat$(i) = Right$("00" + Trim(Str(resnum)), 2)
Next i
Case "-"
retenue = 0
For i = 2 To 0 Step -1
tableau$(0,i)=right("00" & tableau$(0,i),2)
tableau$(1,i)=right("00" & tableau$(1,i),2)
If Val(tableau$(0, i)) < Val(tableau$(1, i)) Then
resnum = 60 + Val(tableau$(0, i)) - (Val(tableau$(1, i)) + retenue)
retenue = 1
Else
resnum = Val(tableau$(0, i)) - (Val(tableau$(1, i)) + retenue)
retenue = 0
End If
Resultat$(i) = Right$("00" + Trim(Str(resnum)), 2)
Next i
End Select
if tableau$(0,0)="00" and tableau$(1,0)="00" then
terme1 = MIif(Left$(tableau$(0, 1), 1) = "0", Right$(tableau$(0, 1), 1), tableau$(0, 1)) & "m" & tableau$(0, 2) & "s"
terme2 = Operation & MIif(Left$(tableau$(1, 1), 1) = "0", Right$(tableau$(1, 1), 1), tableau$(1, 1)) & "m" & tableau$(1, 2) & "s"
resul = MIif(Left$(Resultat$(1), 1) = "0", Right$(Resultat$(1), 1), Resultat$(1)) & "m" & Resultat$(2) & "s"
else
terme1 = MIif(Left$(tableau$(0, 0) = "0", Right$(tableau$(0, 0), 1), tableau$(0, 0)) & "h" & tableau$(0, 1) & "m" & tableau$(0, 2) & "s"
terme2 = Operation & MIif(Left$(tableau$(1, 0), 1) = "0", Right$(tableau$(1, 0), 1), tableau$(1, 0)) & "h" & tableau$(1, 1) & "m" & tableau$(1, 2) & "s"
resul = MIif(Left$(Resultat$(0), 1) = "0", Right$(Resultat$(0), 1), Resultat$(0)) & "h" & Resultat$(1) & "m" & Resultat$(2) & "s"
End If
AfficheTexte 10, 1, terme1, False, 0, Shapes, l, h
AfficheTexte 10, 2, terme2, False, 0, Shapes, l, h
TraceLigneGroupe Shapes, "s", oAdditionForm.Model.Image1
AfficheTexte 10, 3, resul, False, 0, Shapes, l, h
GroupeObjet(Shapes)
TermineDessin()
End Sub
Sub DimensionTexte(texte,taillefonte,l,h)
Dim xShape As Object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
xShape = oDocumentDessin.createInstance("com.sun.star.drawing.TextShape")
aPoint.x = 0
aPoint.y = 0
aSize.Width = 10
aSize.Height = 10
xShape.Position = aPoint
xShape.Size=aSize
oDocumentDessin.DrawPages.GetByIndex(0).add(xShape)
xShape.String = texte
xShape.Text.CharHeight=taillefonte
xShape.Text.TextAutoGrowWidth=True
xShape.Text.TextAutoGrowHeight=True
xShape.Text.TextLeftDistance=0
xShape.Text.TextRightDistance=0
'xShape.Text.TextUpperDistance=0
'xShape.Text.TextLowerDistance=0
l=xShape.Size.Width
h=xShape.Size.Height
oDocumentDessin.DrawPages.GetByIndex(0).remove(xShape)
End Sub
Function AfficheRetenue(x, y, t, sgroupe As Object,l,h) as Object
Dim j As Integer
Dim c As String
Dim xShape As Object
Dim aPoint As New com.sun.star.awt.Point
Dim n
For j = 1 To Len(t)
c = Mid$(t, Len(t) + 1 - j, 1)
if c<>"0" then
xShape = oDocumentDessin.createInstance("com.sun.star.drawing.TextShape")
oDocumentDessin.DrawPages.GetByIndex(0).add(xShape)
xShape.String = c
xShape.Text.CharFontName = OOoGdmath_NomPolice
xShape.Text.CharHeight = OOoGdmath_TaillePolice/2.4
xShape.Text.CharPosture=com.sun.star.awt.FontSlant.ITALIC
xShape.Text.TextAutoGrowWidth=True
xShape.Text.TextAutoGrowHeight=True
aPoint.x = (x-j)*l*2
aPoint.y = y*h
xShape.Position = aPoint
If Not IsMissing(sgroupe) Then sgroupe.add(xShape)
n=1
End if
Next j
if n=1 then
AfficheRetenue()=xShape
else
AfficheRetenue()=Nothing
end if
End Function
Function AfficheTexte(x, y, t, virgule, place, sgroupe As Object,l,h) as Object
Dim j As Integer
Dim c As String
Dim xShape As Object
Dim aPoint As New com.sun.star.awt.Point
If virgule Then
While place >= Len(t)
t = "0" & t
Wend
End If
For j = 1 To Len(t)
c = Mid$(t, Len(t) + 1 - j, 1)
If c = "m" Then c = "min"
'if c=chr(180) then c=chr(215)
xShape = oDocumentDessin.createInstance("com.sun.star.drawing.TextShape")
oDocumentDessin.DrawPages.GetByIndex(0).add(xShape)
If virgule And j - 1 = place Then
xShape.String = c & ","
Else
xShape.String = c
End If
xShape.Text.CharFontName = OOoGdmath_NomPolice
xShape.Text.CharHeight = OOoGdmath_TaillePolice
xShape.Text.TextAutoGrowWidth=True
xShape.Text.TextAutoGrowHeight=True
xShape.Text.TextLeftDistance=0
xShape.Text.TextRightDistance=0
'xShape.Text.TextUpperDistance=0
'xShape.Text.TextLowerDistance=0
aPoint.x = (x-j)*l*2
aPoint.y = y*h
xShape.Position = aPoint
If Not IsMissing(sgroupe) Then sgroupe.add(xShape)
Next j
AfficheTexte()=xShape
End Function
Sub RemplaceChiffreCaractere(texte$, Caractere)
Dim k, nTexte$, j
Dim a$
k = Len(texte$)
nTexte$ = ""
For j = 1 To k
a$ = Mid$(texte$, j, 1)
If a$ >= "0" And a$ <= "9" Then
nTexte$ = nTexte$ & Caractere
Else
nTexte$ = nTexte$ & a$
End If
Next j
texte$ = nTexte$
End Sub
Sub Operation(UnTexte As String, Optional Resultat as Boolean)
Dim Param$(2, 3)
Dim parametre() as string
Dim operande() as string
Dim texte$, a, b, texte1$, texte2$, noperande1, i, noperande2, MM, m, terme1, terme2
Dim uneOperation
if instr(1,unTexte,"+")<>0 then UneOperation="+"
if instr(1,unTexte,"-")<>0 then UneOperation="-"
if instr(1,unTexte,"*")<>0 then UneOperation="*"
if instr(1,unTexte,"/")<>0 then UneOperation="/"
if ismissing(Resultat) then Resultat=False
texte$ = unTexte
If InStr(1, texte$, ":") Then
SupprimeEspace texte$
' Operations sexegesimales
ChargeParametre texte$, operande(), UneOperation
ChargeParametre operande(0), parametre(), ":"
for i=lbound(parametre()) to ubound(parametre())
parametre(i)=left("00", 2-len(parametre(i))) & parametre(i)
param$(0,i + 2 - ubound(parametre()))=parametre(i)
next i
ChargeParametre operande(1), parametre(), ":"
for i=lbound(parametre()) to ubound(parametre())
parametre(i)=left("00", 2-len(parametre(i))) & parametre(i)
param$(1,i + 2 - ubound(parametre()))=parametre(i)
next i
InsereAdditionSoustractionSexa Param$(), UneOperation
Else
MM = Left$(texte$, InStr(1, texte$, UneOperation) - 1)
RemplaceVirgulePoint MM
m = Right$(texte$, Len(texte$) - InStr(1, texte$, UneOperation))
RemplaceVirgulePoint m
Select Case UneOperation
Case "*"
' InsereMultiplication MM, m, False
Case "+"
InsereAdditionSoustraction MM, m, "+", MIif(Resultat, oAdditionForm.Model.TextBox3.Text, "")
Case "-"
If Val(MM) < Val(m) Then
MsgBoxP "message1"
Else
InsereAdditionSoustraction MM, m, "-", MIif(Resultat, oAdditionForm.Model.TextBox3.Text, "")
End If
Case "/"
' InsereDivisionEntiere MM, m, False
End Select
End If
End Sub
Sub InsereAdditionSoustraction(terme1, terme2, Operation, OperationTrou)
Dim terme(10) As String
Dim sterme(10) As String
Dim retenue as string
Dim retenues as string
Dim pemax as Integer
Dim ncmax as integer
Dim nchiffre(10) As Integer
Dim pechiffre(10) as integer
Dim l,h, i, j, k, ResultatN, Resultat$, imax, imaxd, Signe
Dim Shapes as Object
Dim tot as integer
terme(1) = terme1
terme(2) = terme2
RemplaceVirgulePoint terme(1)
RemplaceVirgulePoint terme(2)
i = 1
k = 2
While InStr(i, terme2, "+") <> 0
j = InStr(i, terme2, "+")
terme(k) = Mid$(terme2, i, j - i)
RemplaceVirgulePoint terme(k)
i = j + 1
k = k + 1
Wend
terme(k) = Right$(terme2, Len(terme2) - i + 1)
RemplaceVirgulePoint terme(k)
k = k + 1
If Operation = "+" Then
ResultatN = 0
For i = 1 To k
ResultatN = ResultatN + Val(terme(i))
Next i
Resultat$ = Str(ResultatN)
End If
If Operation = "-" Then Resultat$ = Str(Val(terme(1)) - Val(terme(2)))
Resultat$ = Right$(Resultat$, Len(Resultat$) - 1)
terme(k) = Resultat$
pemax = 0
ncmax = 0
For i = 1 To k
nchiffre(i) = InStr(1, terme(i), ".")
if nchiffre(i) = 0 then
pechiffre(i) = len(terme(i))
else
pechiffre(i) = nchiffre(i) - 1
end if
if pemax < pechiffre(i) then pemax = pechiffre(i)
If nchiffre(i) > 0 Then nchiffre(i) = Len(terme(i)) - nchiffre(i)
If nchiffre(i) > 0 Then terme(i) = Left$(terme(i), Len(terme(i)) - 1 - nchiffre(i)) & Right$(terme(i), nchiffre(i))
if ncmax < nchiffre(i) then ncmax = nchiffre(i)
Next i
For i=1 to k
sterme(i) = left$("0000000000", pemax-pechiffre(i)) & terme(i) & left$("0000000000", ncmax-nchiffre(i))
next i
if oAdditionForm.Model.CheckBox2.State Then
if Operation="+" then
retenue = ""
for i = 1 to len(sterme(1))
tot = 0
for j= 1 to k-1
tot = tot + val(mid(sterme(j),i,1)
next j
retenue = retenue & trim(str(int(tot/10)))
next i
retenue = retenue & "0"
else
retenue = ""
retenues = ""
for i = 1 to len(sterme(1))
if val(mid(sterme(1),i,1)) < val(mid(sterme(2),i,1)) then
retenue = retenue & "1"
retenues = retenues & "1"
else
retenue = retenue & "0"
retenues = retenues & "0"
end if
next i
retenues = retenues & "0"
End if
End if
InitialiseDessin(False)
Shapes=InitialiseGroupe()
DimensionTexte "8",12,l,h
if oAdditionForm.Model.CheckBox2.State Then
AfficheRetenue 9.8 + ncmax, 0.8, retenue, Shapes, l, h
if Operation <> "+" then AfficheRetenue 9.7 + ncmax, 2.7, retenues, Shapes, l, h
End if
AfficheTexte 10 + nchiffre(1), 1, terme(1), nchiffre(1) > 0, nchiffre(1), Shapes, l, h
imax = Len(terme(1)) - nchiffre(1)
imaxd = nchiffre(1)
For i = 2 To k
If imax < Len(terme(i)) - nchiffre(i) Then
imax = Len(terme(i)) - nchiffre(i)
End If
If imaxd < nchiffre(i) Then
imaxd = nchiffre(i)
End If
Next i
For i = 2 To k-1
AfficheTexte 10 + nchiffre(i), i, Operation & left(" ", pemax - pechiffre(i)) & terme(i), nchiffre(i) > 0, nchiffre(i), Shapes,l,h
Next i
TraceLigneGroupe Shapes, "s", oAdditionForm.Model.Image1
If OperationTrou <> "" Then RemplaceChiffreCaractere terme(k), OperationTrou
AfficheTexte 10 + nchiffre(k), MIif(Operation="+",k,k+.3), terme(k), nchiffre(k) > 0, nchiffre(k), Shapes,l,h
GroupeObjet(Shapes)
TermineDessin()
End Sub
</script:module><?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script"; script:name="DivisionCode" script:language="StarBasic">'OOoGdmath
'Copyright (C) 2005-2009 Gilles Daurat
'This program is free software; you can redistribute it and/or
'modify it under the terms of the GNU General Public License
'as published by the Free Software Foundation; either version 2
'of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
Option Explicit
Global oDivisionForm as object
Sub Main
oDivisionForm = LoadDialog("OOoGdmath","DivisionForm")
ChangeTitreDialog(oDivisionForm)
' RestaureForm(oDivisionForm)
oDivisionForm.Execute()
End Sub
Private Sub DivisionCode_CheckBox1_Click()
oDivisionForm.Model.TextBox4.Enabled = oDivisionForm.Model.CheckBox1.State
End Sub
Private Sub DivisionCode_CommandButton1_Click()
Dim quot, DD, d, param() as string
oDivisionForm.EndExecute
sauveForm(oDivisionForm)
quot=oDivisionForm.Model.TextBox1.Text
if val(quot)<>0 and instr(1,quot,"/")>0 then
ChargeParametre quot, param(), "/"
DD=param(0)
d=param(1)
RemplaceVirgulePoint DD
DD=trim(str(val(DD))) 'Ignorieren unzulässiger Zeichen
RemplaceVirgulePoint d
d=trim(str(val(d))) 'Ignorieren unzulässiger Zeichen
if val(d)<>0 then InsereDivisionEntiere DD, d, MIif(oDivisionForm.Model.CheckBox1.State, MIif(oDivisionForm.Model.TextBox4.Text = "", ".", oDivisionForm.Model.TextBox4.Text), "")
end if
End Sub
Private Sub DivisionCode_CommandButton2_Click()
oDivisionForm.EndExecute
End Sub
Private Sub DivisionCode_Image1_Click()
ChangeCouleur oDivisionForm.Model.Image1
End Sub
Private Sub DivisionCode_TextBox4_Change()
oDivisionForm.Model.TextBox4.Text = Left$(oDivisionForm.Model.TextBox4.Text, 1)
End Sub
Private Sub DivisionForm_ScrollBar1()
dim dez as string
dez=oDivisionForm.Model.ScrollBar1.ScrollValue
oDivisionForm.Model.TextBox3.Text=dez
End Sub
Private Sub DivisionForm_ScrollBar1_Mouse()
oDivisionForm.Model.ScrollBar1.Scrollvalue= oDivisionForm.Model.TextBox3.Text
End Sub
Sub InsereDivisionEntiere(DD, d, OperationTrou)
Dim l,h, nchiffre, nchiffred, nchiffreq, nDD, zz, Q, qq$, Debut, DD1, nchiffred_ori
Dim restei, qqTempo$, i, DD2, qi, di$, j, v, vz
Dim Shapes as Object
DIM vert as boolean
DIM DD_ori,DD_ohne, d_ori, DDTemp$, dTemp$ as string
InitialiseDessin(False)
Shapes=InitialiseGroupe
DimensionTexte "8",12,l,h
vert= oDivisionForm.Model.OptionButton1.State
vz="" 'Vorzeichen des Ergebnisses
v=0 ' Versatz für ursprüngliche Aufgabe
nchiffre = Val(oDivisionForm.Model.TextBox3.Text)
sci2dec DD 'Umwandeln wissenschaftliche Zahldarstellung in dezimal
nchiffred = InStr(1, DD, ".")
If nchiffred <> 0 Then nchiffred = Len(DD) - nchiffred 'Dezimalstellen Dividend
sci2dec d
nchiffreq = InStr(1, d, ".")
If nchiffreq <> 0 Then nchiffreq = Len(d) - nchiffreq 'Dezimalstellen Divisor
DD_ori=MIif(nchiffred=0,DD,left(DD,len(DD)-nchiffred-1)) & right(DD,nchiffred)
d_ori=MIif(nchiffreq=0,d,left(d,len(d)-nchiffreq-1)) & right(d,nchiffreq)
nchiffred_ori=nchiffred
If nchiffreq > 0 Then 'Erweitern auf ganzzahligen Divisor
DD = Trim(Val(DD) * 10 ^ nchiffreq)
RemplaceVirgulePoint DD
sci2dec DD
d = Trim(Val(d) * 10 ^ nchiffreq)
nchiffred = InStr(1, DD, ".")
If nchiffred <> 0 Then nchiffred = Len(DD) - nchiffred
End If
if val(DD)<0 then
DD=mid(DD,2)
vz="-"
end if
if val(d)<0 then
d=mid(d,2)
vz=MIif(vz="","-","")
end if
If nchiffre < nchiffred Then nchiffre = nchiffred ' mindestens Genauigkeit der Operanden
If nchiffred>0 then DD=left(DD,len(DD)-nchiffred-1) & right(DD,nchiffred)
DD_ohne=DD
For i=1 to nchiffre-nchiffred
DD=DD & "0"
Next i
qq$ = Trim(Str(Int(Val(DD) / Val(d))))
do while len(qq$)<=nchiffre
qq$ = "0" & qq$
loop
Debut = Len(DD) - Len(qq$)
DD1 = Left$(DD, Debut)
if not vert and (nchiffreq>0 or val(d_ori)<0) then 'ursprüngliche Aufgabe
AfficheTexte Len(DD_ori)+2-Debut, 1, DD_ori & ":", nchiffred_ori > 0, nchiffred_ori+1, Shapes,l,h
if val(d_ori)>0 then
AfficheTexte Len(DD_ori) +3-Debut+ Len(d_ori), 1, d_ori & "=", nchiffreq > 0, nchiffreq+1, Shapes,l,h
else 'mathematisch korrekt mit Klammern
AfficheTexte Len(DD_ori) +5-Debut+ Len(d_ori), 1, "(" & d_ori & ")" & "=", nchiffreq > 0, nchiffreq+2, Shapes,l,h
end if
v=1
end if
DDTemp$=DD_ohne
dTemp$=d
if vert then
InsereLigne 2*l * (Len(vz & DD) - Debut+1.2), h*(1+0.2), 2*l * (Len(vz & DD) - Debut+1.2), h*(3), Shapes, oDivisionForm.Model.Image1
InsereLigne 2*l * (Len(vz & DD) - Debut+1.2), h*(2), 2*l * (Len(vz & DD) - Debut + Len(d)+1.5), h*(2), Shapes, oDivisionForm.Model.Image1
AfficheTexte Len(vz & DD) + 1 - Debut, 1, vz & DD, nchiffre > 0, nchiffre, Shapes,l,h
AfficheTexte Len(vz & DD) + 2 - Debut + Len(d), 1, d, False, 0, Shapes,l,h
else
if v=1 and OperationTrou <> "" then '
RemplaceChiffreCaractere DDTemp$, OperationTrou
RemplaceChiffreCaractere dTemp$, OperationTrou
end if
AfficheTexte Len(vz & DD_ohne) + 2 - Debut, 1+v, vz & DDTemp$ & ":", nchiffred > 0, nchiffred+1, Shapes,l,h
AfficheTexte Len(vz & DD_ohne) + 3 - Debut + Len(d), 1+v, dTemp$ & "=", False, 0, Shapes,l,h
end if
qqTempo$ = qq$
If OperationTrou <> "" Then
RemplaceChiffreCaractere qq$, OperationTrou
end if
'Ergebnisanzeige
if vert then
AfficheTexte Len(vz & DD) + 2 - Debut + Len(vz & qq$), 2, vz & qq$, nchiffre > 0, nchiffre, Shapes,l,h
else
'AfficheTexte Len(DD_ohne) + 3 - Debut + len(d) + Len(qq$), 1, qq$, nchiffre > 0, nchiffre, Shapes,l,h
AfficheTexte Len(vz & DD_ohne) + 3 - Debut + len(d) + Len(vz & qq$), 1+v, vz & qq$, nchiffre > 0, nchiffre, Shapes,l,h
end if
qq$ = qqTempo$
For i = 1 To Len(qq)
DD2 = DD1 & Mid$(DD, Debut + i, 1)
qi = Mid$(qq$, i, 1)
di$ = Str(Val(qi) * Val(d))
di$ = Right$(di, Len(di$) - 1)
restei = Str(Val(DD2) - Val(di$))
DD1 = Right$(restei, Len(restei) - 1)
For j = 1 To Len(DD2) - Len(di$)
di$ = " " & di$
Next j
If i = Len(qq$) Then
AfficheDivisionP i + 1, 2 * i+v, di$, DD1 & " ", OperationTrou,Shapes,l,h
Else
AfficheDivisionP i + 1, 2 * i+v, di$, DD1 & Mid$(DD, Debut + i + 1, 1), OperationTrou,Shapes,l,h
End If
Next i
Dim aPoint As New com.sun.star.awt.Point
Dim TheSize as new com.sun.star.awt.Size
Dim Group as Object
aPoint.x=3000
aPoint.y=3000
Group = GroupeObjet(Shapes)
Group.Position=aPoint
TermineDessin()
End Sub
Sub AfficheDivisionP(x, y, d$, r$, OperationTrou,Shapes,l,h)
If oDivisionForm.Model.CheckBox2.State Then
If OperationTrou <> "" Then RemplaceChiffreCaractere d$, OperationTrou
AfficheTexte x, y, "-" & d$, False, 0, Shapes,l,h
if right(r$,1)=" " then
InsereLigne 2*l * (x - 1 - Len(d$)), h * (y + 1), 2*l * (x), h * (y + 1), Shapes, oDivisionForm.Model.Image1
else
InsereLigne 2*l * (x - 1 - Len(d$)), h * (y + 1), 2*l * (x+1), h * (y + 1), Shapes, oDivisionForm.Model.Image1
end if
End If
If OperationTrou <> "" Then RemplaceChiffreCaractere r$, OperationTrou
If oDivisionForm.Model.CheckBox2.State Then
AfficheTexte x + 1, y+1, r$, False, 0, Shapes,l,h
Else
AfficheTexte x + 1, Int((y) / 2+0.5)+1, r$, False, 0, Shapes,l,h
End If
End Sub
Sub sci2dec(nombre)
DIM n as integer
DIM x,y
DIM vz
vz=""
nombre=trim(nombre)
n= instr(nombre,"E")
if n>0 then
x=left(nombre,n-1)
y=val(mid(nombre,n+1))
if left(x,1)="-" then
vz="-"
x=mid(x,2)
end if
n=len(x)-instr(x,".")
if n>0 then
x=left(x,1) & mid(x,3)
end if
if y<0 then
x="0." & string(-1-y,"0") & x
else
if n>y then
n=n-y
x=left(x,len(x)-n) & "." & right(x,n)
else
x=x & string(y-n,"0")
end if
end if
nombre=vz & x
end if
End Sub
</script:module><?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script"; script:name="Gdmath" script:language="StarBasic">'OOoGdmath
'Copyright (C) 2005-2009 Gilles Daurat
'This program is free software; you can redistribute it and/or
'modify it under the terms of the GNU General Public License
'as published by the Free Software Foundation; either version 2
'of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
option explicit
Global Const VERSION_GDMATH= "2013.12.07"
Global Const Pi = 3.14159265358979
Global Const FG_RIEN = 0
Global Const FG_CROIX = 1
Global Const FG_TRAIT = 2
Global Const rText = 0
Global Const rLabel = 1
Global Const rHelpText = 2
Global Const rTitle = 3
Global oPageDessin as Object
Global oDocumentDessin as Object
Global oPageTexte as Object
Global oDocumentTexte as Object
Global oPageDessin1 as Object
Global oDocumentDessin1 as Object
Global oPremierDocument as Object
Dim oUneBoite as Object
Dim BoiteChaineOk as integer
Sub Main
End Sub
function fCheminImages() as String rem écrite par Jérôme Ortais
Dim newSplit()
ReDim NewSplit(0)
Dim thePath as string
Dim splitted
thePath = basiclibraries.getLibraryLinkURL("OOoGdmath") rem à adapter.
splitted = split(thePath,"/")
newSplit() = splitted()
ReDim Preserve newSplit(0 to ubound(splitted)-2)
fCheminImages = join(NewSplit(),"/") & "/" & "OOoGdmath/Bitmaps/"
End Function
Function GetRepertoirePath(sInstPath as String) as String 'donne le répertoire correspondant
Dim oPathSubstSrv as Object
Dim sPath as String
sInstPath = "$(" & sInstPath & ")"
oPathSubstSrv =createUnoService("com.sun.star.comp.framework.PathSubstitution")
sPath =ConvertFromUrl(oPathSubstSrv.getSubstituteVariableValue(sInstPath))
GetRepertoirePath = sPath
End Function
Sub ChangeTitreDialog(uneDialogue as Object)
InitialiseGdmath()
if instr(1,uneDialogue.Title,VERSION_GDMATH)=0 then
uneDialogue.Title=Ressource(uneDialogue,rTitle) & " - " & VERSION_GDMATH
End if
End Sub
Sub AACExtraitNDF(Fraction as string, num as string, den as string)
Dim a
a = InStr(1, Fraction, "/")
If a <> 0 Then
num = Trim(Left(Fraction, a - 1))
den = Trim(Right(Fraction, Len(Fraction) - a))
Else
num = Trim(Fraction)
den = "1"
End If
If Left(num, 1) = "-" Then num = Mid(num, 2)
End Sub
Function CestUneFigureGeometrique() as Boolean
on error resume next
CestUneFigureGeometrique=False
CestUneFigureGeometrique = (oRectangleForm.Model.CheckBox12.State Or oTriangleForm.Model.CheckBox38.State Or oCercleForm.Model.CheckBox8.State Or oCarreForm.Model.CheckBox12.State)
End Function
Function MarqueMilieu(x0, y0, x1, y1, ts As Object, Optional UneImage As Image) as Object
Dim xm, ym, r
xm = (x0 + x1) / 2
ym = (y0 + y1) / 2
r = Sqr((x0 - xm) * (x0 - xm) + (y0 - ym) * (y0 - ym))
InsereLigne xm - 100 * (y0 - ym) / r, ym + 100 * (x0 - xm) / r, xm + 100 * (y0 - ym) / r, ym - 100 * (x0 - xm) / r, ts, UneImage
End Function
Sub CopierColler()
Dim oDispatcher as Object
Dim oEmptyShapeCollection as Object
Dim oDrawDocView as Object,oTextDocView as Object
' Get a dispatcher, because we'll need it later.
oDispatcher = createUnoService( "com.sun.star.frame.DispatchHelper" )
' Get an empty collection of shapes. We'll need it lager.
oEmptyShapeCollection = createUnoService( "com.sun.star.drawing.ShapeCollection" )
' Get the document's controller
oDrawDocView = oDocumentDessin.getCurrentController()
oTextDocView = oPremierDocument.getCurrentController()
' Copy whatever is selected.
oDispatcher.executeDispatch( oDrawDocView.Frame, ".uno:Copy", "", 0, Array() )
' Select nothing -- i.e. an empty collection of shapes.
' If you stopped the macro right now and looked at the drawing -- nothing is selected.
oTextDocView.select( oEmptyShapeCollection )
' Now paste whatever is in the clipboard (the shape parameter) onto current page.
oDispatcher.executeDispatch( oTextDocView.Frame, ".uno:Paste", "", 0, Array() )
' After a Paste, the current selection is whatever we just pasted.
End Sub
Sub CopierColler1()
Dim oDispatcher as Object
Dim oEmptyShapeCollection as Object
Dim oDrawDocView as Object,oTextDocView as Object
' Get a dispatcher, because we'll need it later.
oDispatcher = createUnoService( "com.sun.star.frame.DispatchHelper" )
' Get an empty collection of shapes. We'll need it lager.
oEmptyShapeCollection = createUnoService( "com.sun.star.drawing.ShapeCollection" )
' Get the document's controller
oDrawDocView = oDocumentDessin.getCurrentController()
oTextDocView = oDocumentTexte.getCurrentController()
' Copy whatever is selected.
oDispatcher.executeDispatch( oTextDocView.Frame, ".uno:Copy", "", 0, Array() )
' Select nothing -- i.e. an empty collection of shapes.
' If you stopped the macro right now and looked at the drawing -- nothing is selected.
oDrawDocView.select( oEmptyShapeCollection )
' Now paste whatever is in the clipboard (the shape parameter) onto current page.
oDispatcher.executeDispatch( oDrawDocView.Frame, ".uno:Paste", "", 0, Array() )
' After a Paste, the current selection is whatever we just pasted.
End Sub
Sub Copier1()
dim dsp as Object
dsp=CreateUnoService("com.sun.star.frame.DispatchHelper")
dsp.executeDispatch(oDocumentTexte.CurrentController.Frame, ".uno:Cut", "", 0, Array())
End Sub
Sub Coller1()
dim dsp as object
dsp=CreateUnoService("com.sun.star.frame.DispatchHelper")
dsp.executeDispatch(oDocumentDessin.GetCurrentController().Frame, ".uno:Paste", "", 0, Array())
oDocumentDessin.CurrentController.Select(oPageDessin(0))
End Sub
Sub InitialiseDessin(Optional visible as Boolean)
'Didier Dorange-Pattoret
Dim mFileProperties(0) As New com.sun.star.beans.PropertyValue
Dim Array()
if IsMissing(visible) then visible = True
mFileProperties(0).Name="Hidden"
mFileProperties(0).Value=True
oPremierDocument=thisComponent
if visible then
oDocumentTexte=StarDesktop.LoadComponentFromURL("private:factory/swriter","_blank", 0, Array())
oPageTexte=oDocumentTexte.drawPage()
oDocumentDessin=StarDesktop.LoadComponentFromURL("private:factory/sdraw","_blank", 0, Array())
else
oDocumentTexte=StarDesktop.LoadComponentFromURL("private:factory/swriter","_blank", 0, mFileProperties())
oPageTexte=oDocumentTexte.drawPage()
oDocumentDessin=StarDesktop.LoadComponentFromURL("private:factory/sdraw","_blank", 0, mFileProperties())
oDocumentDessin.lockControllers
oDocumentTexte.lockControllers
oPremierDocument.lockControllers
End if
oPageDessin=oDocumentDessin.DrawPages(0)
end sub
sub TermineDessin()
' on groupe tous les objets de la feuille
dim i
dim unGroupe as Object
on error resume next
' unGroupe=InitialiseGroupe()
for i=0 to oPageDessin.Count()-1
SelectionneForme(oDocumentDessin, oPageDessin(i))
' unGroupe.add(oPageDessin(i))
next i
' unGroupe=GroupeObjet(unGroupe)
' SelectionneForme(oDocumentDessin, unGroupe)
CopierColler()
' Copier()
' Coller()
on error resume next
oDocumentDessin.close(True)
oDocumentTexte.close(true)
oPremierDocument.unlockControllers
on error goto 0
end sub
sub TermineDessin2()
' on groupe tous les objets de la feuille
dim i
dim unGroupe as Object
' on error resume next
unGroupe=InitialiseGroupe()
for i=0 to oPageDessin.Count()-1
' SelectionneForme(oDocumentDessin, oPageDessin(i))
unGroupe.add(oPageDessin(i))
next i
unGroupe=GroupeObjet(unGroupe)
SelectionneForme(oDocumentDessin, unGroupe)
CopierColler()
' Copier()
' Coller()
on error resume next
oDocumentDessin.close(True)
oDocumentTexte.close(true)
oPremierDocument.unlockControllers
on error goto 0
end sub
function CentimetersToPoints(a) as double
CentimetersToPoints=a*1000
end function
function monval(texte as string)
remplacevirgulepoint(texte)
monval = val(texte)
end function
Sub RemplaceVirgulePoint(nombre)
Dim k as Integer
k = InStr(1, nombre, ",")
If k <> 0 Then nombre = Left$(nombre, k - 1) & "." & Right$(nombre, Len(nombre) - k)
End Sub
Sub RemplacePointVirgule(nombre)
Dim k as Integer
k = InStr(1, nombre, ".")
If k <> 0 Then nombre = Left$(nombre, k - 1) & "," & Right$(nombre, Len(nombre) - k)
End Sub
Sub MarquePointSegment(xi as single, yi as single, x0 as single, y0 as single, x1 as single, y1 as single,optional sGroupe as object)
Dim r as Single
r = Sqr((x0 - xi) * (x0 - xi) + (y0 - yi) * (y0 - yi))
if not ismissing(sgroupe) then
InsereLigne(xi - 100 * (y0 - yi) / r, yi + 100 * (x0 - xi) / r, xi + 100 * (y0 - yi) / r, yi - 100 * (x0 - xi) / r, sGroupe)
else
InsereLigne(xi - 100 * (y0 - yi) / r, yi + 100 * (x0 - xi) / r, xi + 100 * (y0 - yi) / r, yi - 100 * (x0 - xi) / r)
end if
End Sub
function max(val1,val2)
if val1>val2 then
max()=val1
else
max()=val2
end if
end function
function min(val1,val2)
if val1>val2 then
min()=val2
else
min()=val1
end if
end function
function InsereLigneLongue(l, x0, y0, x1, y1, optional sgroupe as object) as object
Dim UnObjet As object
Dim r as Single
r = Sqr((x0 - x1) * (x0 - x1) + (y0 - y1) * (y0 - y1))
if not ismissing(sgroupe) then
InsereLigneLongue()=InsereLigne(Min(x0, x1) - Abs(l * (x0 - x1) / r), _
Min(y0, y1) - Abs(l * (y0 - y1) / r), _
max(x0, x1) + Abs(l * (x0 - x1) / r), _
max(y0, y1) + Abs(l * (y0 - y1) / r), sgroupe)
else
InsereLigneLongue()=InsereLigne(Min(x0, x1) - Abs(l * (x0 - x1) / r), _
Min(y0, y1) - Abs(l * (y0 - y1) / r), _
max(x0, x1) + Abs(l * (x0 - x1) / r), _
max(y0, y1) + Abs(l * (y0 - y1) / r))
end if
End function
function ListBoxSelected(oListBox as object, indice as integer) as boolean
Dim retour as Boolean
Dim aa
Dim i as Integer
retour=False
aa=oListBox.GetSelectedItemsPos()
for i=lbound(aa) to ubound(aa)
if aa(i)=indice then retour=True
next i
ListBoxSelected()=retour
end function
Function TraceCodageTrait(xxx as single, yyy as single, Angle as single, Optional SGroupe as object) as object
If Not IsMissing( SGroupe ) Then
TraceCodageTrait()=InsereLigne(xxx + 150 * Cos(Angle), yyy + 150 * Sin(Angle), xxx - 150 * Cos(Angle), yyy - 150 * Sin(Angle), SGroupe)
else
TraceCodageTrait()=InsereLigne(xxx + 150 * Cos(Angle), yyy + 150 * Sin(Angle), xxx - 150 * Cos(Angle), yyy - 150 * Sin(Angle))
end if
End function
Sub TrouvePiedHauteur(x0 as single, y0 as single, x1 as single, y1 as single, xs as single, ys as single, xp as single, yp as single)
Dim uangle as Double
uangle = CalculeAngle(x0,y0,x1,y1)+Pi/2
TrouveIntersection(x0, y0, x1, y1, xs, ys, xs+5000 * Cos(uangle), ys+5000 * Sin(uangle), xp, yp)
End Sub
Function TrouveIntersection(x0 as single, y0 as single, x1 as single, y1 as single, x2 as single, y2 as single, x3 as single, y3 as single, xint as single, yint as single) as Boolean
Dim a1 as single, b1 as single
Dim a0 as single, b0 as single
TrouveIntersection() = True
If x1 = x0 Then
xint = x0
If x3 = x2 Then
xint = "n"
yint = "n"
TrouveIntersection() = False
Else
a1 = (y3 - y2) / (x3 - x2)
b1 = -x2 * a1 + y2
yint = a1 * xint + b1
End If
Else
a0 = (y1 - y0) / (x1 - x0)
b0 = -x0 * a0 + y0
If x3 = x2 Then
xint = x2
yint = a0 * xint + b0
Else
a1 = (y3 - y2) / (x3 - x2)
b1 = -x2 * a1 + y2
xint = (b1 - b0) / (a0 - a1)
yint = a0 * (b1 - b0) / (a0 - a1) + b0
End If
End If
End Function
Sub CalculeOrthocentre(x0 as single, y0 as single, x1 as single, y1 as single, x2 as single, y2 as single, xh as single, yh as single)
Dim xph1 as single, xph2 as single, yph1 as single, yph2 as single
TrouvePiedHauteur(x0, y0, x1, y1, x2, y2, xph2, yph2)
TrouvePiedHauteur(x0, y0, x2, y2, x1, y1, xph1, yph1)
TrouveIntersection(x2, y2, xph2, yph2, x1, y1, xph1, yph1, xh, yh)
End Sub
function TraceHauteur(xxx0 as single, yyy0 as single, xx1 as single, yy1 as single, xx2 as single, yy2 as single, sGroupe as object, xh1 as single, yh1 as single, xh2 as single, yh2 as single, Optional ProlongerHauteurS as Boolean, Optional ProlongerHauteurP as Boolean, Optional ProlongerCote as Boolean , Optional ProlongerHauteurI as Boolean, Optional xh as single, Optional yh as single) as object
Dim pGroupe as object
Dim unObjet as Object
Dim xx as single, yy as single
Dim xx0 as single, yy0 as single
Dim p1 as single, p2 as single
Dim pp1 as single, pp2 as single
Dim test1 as Boolean, test2 as Boolean
Dim angleh as double
pGroupe=InitialiseGroupe()
xx0 = xxx0
yy0 = yyy0
TrouvePiedHauteur(xx1, yy1, xx2, yy2, xx0, yy0, xx, yy)
MarqueAngleDroit(xx, yy, xx0, yy0, pGroupe)
If Abs(xx1 - xx2) > Abs(yy1 - yy2) Then
test1 = (xx > max(xx1, xx2))
test2 = (xx < Min(xx1, xx2))
If test1 Then
p1 = MIif(xx1 > xx2, xx1, xx2)
p2 = MIif(xx1 > xx2, yy1, yy2)
End If
If test2 Then
p1 = MIif(xx1 < xx2, xx1, xx2)
p2 = MIif(xx1 < xx2, yy1, yy2)
End If
Else
test1 = (yy > max(yy1, yy2))
test2 = (yy < min(yy1, yy2))
If test1 Then
p1 = MIif(yy1 >yy2, xx1, xx2)
p2 = MIif(yy1 >yy2, yy1, yy2)
End If
If test2 Then
p1 = MIif(yy1 <yy2, xx1, xx2)
p2 = MIif(yy1 <yy2, yy1, yy2)
End If
End If
If ProlongerCote And (test1 Or test2) Then
angleh = CalculeAngle(p1, p2, xx, yy)
pp1 = xx + 5000 * Cos(angleh)
pp2 = yy + 5000 * Sin(angleh)
LaLigne=InsereLigne(p1, p2, pp1, pp2, pGroupe)
LaLigne.LineStyle = 0
End If
If ProlongerHauteurS Or ProlongerHauteurP Then
angleh = CalculeAngle(xx0, yy0, xx, yy)
If ProlongerHauteurS Then
xx0 = xx0 - 5000 * Cos(angleh)
yy0 = yy0 - 5000 * Sin(angleh)
End If
If ProlongerHauteurP Then
xx = xx + 5000 * Cos(angleh)
yy = yy + 5000 * Sin(angleh)
End If
End If
If ProlongerHauteurI Then
angleh = CalculeAngle(xx0, yy0, xx, yy)
If xh < Min(xx0, xx) Or yh < Min(yy0, yy) Then
If (xx0 < xx And xh < Min(xx0, xx)) Or (yy0 < yy And yh < Min(yy0, yy)) Then
xx0 = xh - 5000 * Cos(angleh)
yy0 = yh - 5000 * Sin(angleh)
Else
xx = xh + 5000 * Cos(angleh)
yy = yh + 5000 * Sin(angleh)
End If
End If
If xh > max(xx0, xx) Or yh > max(yy0, yy) Then
If (xx0 > xx And xh > max(xx0, xx)) Or (yy0 > yy And yh > max(yy0, yy)) Then
xx0 = xh - 5000 * Cos(angleh)
yy0 = yh - 5000 * Sin(angleh)
Else
xx = xh + 5000 * Cos(angleh)
yy = yh + 5000 * Sin(angleh)
End If
End If
End If
InsereLigne(xx0, yy0, xx, yy, pGroupe)
xh1 = xx0
yh1 = yy0
xh2 = xx
yh2 = yy
UnObjet=GroupeObjet(pGroupe)
if not ismissing(sgroupe) then
sgroupe.add(UnObjet)
end if
TraceHauteur()=UnObjet
End function
function InitialiseGroupe() as object
dim UnGroupe as object
UnGroupe = createUnoService("com.sun.star.drawing.ShapeCollection")
InitialiseGroupe()=UnGroupe
end function
function GroupeObjet(pgroupe as object) as object
Dim UnObjet as object
on error resume next
a=pgroupe.GetCount()
if a>1 then
GroupeObjet=oDocumentDessin.DrawPages.GetByIndex(0).group(pgroupe)
' GroupeObjet=ThisComponent.Drawpage.group(pgroupe)
' GroupeObjet()=ThisComponent.Drawpage.bind(pgroupe)
else
GroupeObjet=pgroupe.GetByIndex(0)
end if
end function
function TraceMediane(xxx0 as single, yyy0 as single, xx1 as single, yy1 as single, xx2 as single, yy2 as single, Optional ProlongerMedianeS as boolean, Optional ProlongerMedianeM as boolean,optional sgroupe as object) as object
dim pGroupe as object
dim xm, ym
dim xx3,yy3,xx0,yy0
dim angleh
Dim seg1 as Object, seg2 as Object
Dim lecodage as Integer
Dim unObjet as Object
pGroupe = InitialiseGroupe()
xm = (xx1 + xx2) / 2
ym = (yy1 + yy2) / 2
xx0 = xxx0
yy0 = yyy0
xx3 = xm
yy3 = ym
If ProlongerMedianeS Or ProlongerMedianeM Then
angleh = CalculeAngle(xx0, yy0, xm, ym)
If ProlongerMedianeS Then
xx0 = xx0 - 5000 * Cos(angleh)
yy0 = yy0 - 5000 * Sin(angleh)
End If
If ProlongerMedianeM Then
xx3 = xx3 + 5000 * Cos(angleh)
yy3 = yy3 + 5000 * Sin(angleh)
End If
End If
InsereLigne(xx0, yy0, xx3, yy3, pgroupe)
' on code les longueurs égales
If (CInt(CodageLabel2) <> 10) Then
Seg1 = InsereLigne(xx1, yy1, xm, ym)
Seg1.LineColor = RGB(0, 0, 255)
Seg2 = InsereLigne(xx2, yy2, xm, ym)
Seg2.LineColor = RGB(255, 0, 0)
AfficheCodageLForm
oPageDessin.remove(seg1)
oPageDessin.remove(seg2)
lecodage = CInt(CodageLabel2)
If (lecodage = 10) Then lecodage = 0
End If
If (CInt(CodageLabel2) = 10) Then
lecodage = lecodage + 1
If lecodage = 10 Then lecodage = 1
End If
If (CodageLabel2 <> "11") Then
CodeLongueur(xx1, yy1, xm, ym, lecodage, pgroupe)
CodeLongueur(xx2, yy2, xm, ym, lecodage, pgroupe)
End If
UnObjet=GroupeObjet(pgroupe)
If Not IsMissing( sgroupe ) Then
sgroupe.add(UnObjet)
end if
TraceMediane()=UnObjet
End function
function TraceCodageCercle(xxx as single, yyy as single, optional sgroupe as object) as object
If Not IsMissing( SGroupe ) Then
TraceCodageCercle()=InsereCercle(xxx, yyy, 150,sgroupe)
else
TraceCodageCercle()=InsereCercle(xxx, yyy, 150)
end if
End function
function InsereCercle(xc as single, yc as single, rayon as single, optional sgroupe as object, Optional uneImage as Object) as object
Dim UneForme As object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
aPoint.x=xc-rayon
aPoint.y=yc-rayon
aSize.Width=rayon*2
asize.Height=rayon*2
UneForme = oDocumentDessin.createInstance("com.sun.star.drawing.EllipseShape")
UneForme.Position=aPoint
UneForme.Size=aSize
' UneForme.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE
UneForme.FillStyle = com.sun.star.drawing.FillStyle.NONE
UneForme.LineColor = RGB(0,0,0)
UneForme.LineWidth = 20
' MRI UneForme
oDocumentDessin.DrawPages.GetByIndex(0).add(UneForme)
If Not IsMissing( SGroupe ) Then
SGroupe.Add(UneForme)
end if
If Not IsMissing(UneImage) Then
IOAttribut(UneForme,UneImage)
End If
InsereCercle()=UneForme
End function
function TraceMediatrice(xx0 as single, yy0 as single, xx1 as single, yy1 as single, xx2 as single, yy2 as single, sgroupe as object, Optional ProlongeMediatrice as boolean, Optional xc as single, Optional yc as single) as object
Dim xm,ym,k,x1,y1,lecodage,anglem,seg1,seg2,xx,yy
xm = (xx0 + xx1) / 2
ym = (yy0 + yy1) / 2
If (xx0 = xx1) Then
yy = ym
xx = xx2
Else
k = (yy0 - yy1) / (xx0 - xx1)
If Abs(k) > 1 Then
xx = xx2
yy = ym + (xm - xx) / k
Else
yy = yy2
xx = xm + k * ym - k * yy
End If
End If
x1 = xm + (xm - xx)
y1 = ym + (ym - yy)
If ProlongeMediatrice Then
anglem = CalculeAngle(xx, yy, x1, y1)
If x1 = xx Then
k = (yc - yy) / (y1 - yy)
Else
k = (xc - xx) / (x1 - xx)
End If
If k > 1 Then
x1 = xc + 5000 * Cos(anglem)
y1 = yc + 5000 * Sin(anglem)
End If
If k < 0 Then
xx = xc - 5000 * Cos(anglem)
yy = yc - 5000 * Sin(anglem)
End If
End If
InsereLigne(xx, yy, x1, y1, sGroupe)
' on trace l'angle droit
MarqueAngleDroit(xm, ym, xx, yy, sGroupe)
' on code les longueurs égales
If (CInt(CodageLabel2) <> 10) Then
Seg1 = InsereLigne(xx1, yy1, xm, ym)
Seg1.LineColor = RGB(0, 0, 255)
Seg2 = InsereLigne(xx0, yy0, xm, ym)
Seg2.LineColor = RGB(255, 0, 0)
AfficheCodageLForm
oDocumentDessin.DrawPages.GetByIndex(0).remove(Seg1)
oDocumentDessin.DrawPages.GetByIndex(0).Remove(Seg2)
lecodage = CInt(CodageLabel2)
If (lecodage = 10) Then lecodage = 0
End If
If (CInt(CodageLabel2) = 10) Then
Do
lecodage = lecodage + 1
If lecodage = 10 Then lecodage = 1
Loop While InStr(1, CodageLabel3, Trim(Str(lecodage))) <> 0
End If
If (CInt(CodageLabel2) < 11) Then
CodeLongueur(xx0, yy0, xm, ym, lecodage, sGroupe, "")
CodeLongueur(xx1, yy1, xm, ym, lecodage, sGroupe, "")
End If
End function
function Croix(x, y, Optional sgroupe as object) as object
Dim pGroupe As object
Dim unObjet as Object
pGroupe=InitialiseGroupe()
InsereLigne(x - 100, y - 100, x + 100, y + 100, pGroupe)
InsereLigne(x - 100, y + 100, x + 100, y - 100, pGroupe)
UnObjet=GroupeObjet(pGroupe)
if not ismissing(sgroupe) then
sgroupe.add(UnObjet)
end if
Croix=UnObjet
End function
Sub CalculeCentreCirconscrit(x0 as single, y0 as single, x1 as single, y1 as single, x2 as single, y2 as single, xc as single, yc as single)
Dim a1 as single, b1 as single, c1 as single
Dim a2 as single, b2 as single, c2 as single
a1 = 2 * (x1 - x0)
b1 = 2 * (y1 - y0)
c1 = x1 * x1 - x0 * x0 + y1 * y1 - y0 * y0
a2 = 2 * (x2 - x0)
b2 = 2 * (y2 - y0)
c2 = x2 * x2 - x0 * x0 + y2 * y2 - y0 * y0
yc = (c1 * a2 - c2 * a1) / (a2 * b1 - a1 * b2)
If a1 = 0 Then
xc = (c2 - b2 * yc) / a2
Else
xc = (c1 - b1 * yc) / a1
End If
End Sub
Function CodeLongueur(xd as single, yd as single, xa as single, ya as single, typecodage as single, optional sgroupe as object) as object
Dim xGroupe As object
Dim UnObjet As object
Dim sTypeCodage
Dim xm1, ym1, alpha, xm0,ym0, xm2, ym2
xGroupe = InitialiseGroupe()
Stypecodage = Trim(Str(typecodage))
If InStr(1, CodageLabel3, Stypecodage) = 0 Then
CodageLabel3 = CodageLabel3 + Stypecodage
If Len(CodageLabel3) = 9 Then
CodageLabel3 = ""
End If
End If
xm1 = (xd + xa) / 2
ym1 = (yd + ya) / 2
alpha = CalculeAngle(xd, yd, xa, ya)
xm0 = xm1 - 100 * Cos(alpha)
ym0 = ym1 - 100 * Sin(alpha)
xm2 = xm1 + 100 * Cos(alpha)
ym2 = ym1 + 100 * Sin(alpha)
TraceCodageTrait(xm1, ym1, alpha + Pi / 3,xGroupe)
If (typecodage Mod 3) = 2 Then
TraceCodageTrait(xm0, ym0, alpha + Pi / 3,xGroupe)
End If
If (typecodage Mod 3) = 0 Then
TraceCodageTrait(xm0, ym0, alpha + Pi / 3,xGroupe)
TraceCodageTrait(xm2, ym2, alpha + Pi / 3,xGroupe)
End If
If typecodage > 3 And typecodage < 7 Then
TraceCodageTrait(xm1, ym1, alpha + 2 * Pi / 3,xGroupe)
End If
If typecodage > 6 And typecodage < 10 Then
TraceCodageCercle(xm1, ym1,xGroupe)
End If
UnObjet=GroupeObjet(xGroupe)
If Not IsMissing( sgroupe ) Then
sgroupe.add(UnObjet)
end if
CodeLongueur()=UnObjet
End function
Sub Echange(val1, val2)
Dim Tempo
tempo = val1
val1 = val2
val2 = tempo
End Sub
function InserePart(xorig as long, yorig as long, depart as long, arrivee as long, Rayon as single, optional sgroupe as object, Optional UneImage as object) as object
Dim UneForme As object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
aPoint.x=xorig-Rayon
aPoint.y=yorig-Rayon
aSize.Width=Rayon*2
asize.Height=Rayon*2
UneForme = oDocumentDessin.createInstance("com.sun.star.drawing.EllipseShape")
' UneForme.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE
UneForme.Position=aPoint
UneForme.Size=aSize
oDocumentDessin.DrawPages.GetByIndex(0).add(UneForme)
UneForme.CircleStartAngle=depart
UneForme.CircleEndAngle=arrivee
UneForme.CircleKind=com.sun.star.drawing.CircleKind.SECTION
If Not IsMissing(UneImage) Then IOAttribut UneForme, UneImage
If Not IsMissing( sgroupe ) Then sgroupe.Add(UneForme)
InserePart()=UneForme
End function
function InsereArcDeCerclePlein(xorig as single, yorig as single, depart as long, arrivee as long, Rayon as single, optional sgroupe as object, Optional UneImage as object) as object
Dim UneForme As object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
aPoint.x=xorig-Rayon
aPoint.y=yorig-Rayon
aSize.Width=Rayon*2
asize.Height=Rayon*2
UneForme = oDocumentDessin.createInstance("com.sun.star.drawing.EllipseShape")
' UneForme.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE
UneForme.Position=aPoint
UneForme.Size=aSize
oDocumentDessin.DrawPages.GetByIndex(0).add(UneForme)
UneForme.CircleStartAngle=depart
UneForme.CircleEndAngle=arrivee
UneForme.CircleKind=com.sun.star.drawing.CircleKind.SECTION
If Not IsMissing(UneImage) Then
IOAttribut UneForme, UneImage
UneForme.FillStyle = com.sun.star.drawing.FillStyle.SOLID
UneForme.FillColor=UneImage.BackgroundColor
end if
If Not IsMissing( sgroupe ) Then
sgroupe.Add(UneForme)
end if
InsereArcDeCerclePlein()=UneForme
End function
function InsereArcDeCercle(xorig as single, yorig as single, depart as long, arrivee as long, Rayon as single, optional sgroupe as object, Optional UneImage as object) as object
Dim UneForme As object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
aPoint.x=xorig-Rayon
aPoint.y=yorig-Rayon
aSize.Width=Rayon*2
asize.Height=Rayon*2
UneForme = oDocumentDessin.createInstance("com.sun.star.drawing.EllipseShape")
' UneForme.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE
UneForme.Position=aPoint
UneForme.Size=aSize
oDocumentDessin.DrawPages.GetByIndex(0).add(UneForme)
UneForme.CircleStartAngle=depart
UneForme.CircleEndAngle=arrivee
UneForme.CircleKind=3
If Not IsMissing(UneImage) Then
IOAttribut UneForme, UneImage
end if
If Not IsMissing( sgroupe ) Then
sgroupe.Add(UneForme)
end if
InsereArcDeCercle()=UneForme
End function
function PetitArcDeCercle(xorig as single, yorig as single, depart as single, arrivee as single, Taille as single, optional sgroupe as object, Optional UneImage as Object) as object
Dim UneForme As object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
aPoint.x=xorig-Taille/2
aPoint.y=yorig-Taille/2
aSize.Width=Taille
asize.Height=Taille
UneForme = oDocumentDessin.createInstance("com.sun.star.drawing.EllipseShape")
UneForme.Position=aPoint
UneForme.Size=aSize
oDocumentDessin.DrawPages.GetByIndex(0).add(UneForme)
UneForme.CircleStartAngle=depart
UneForme.CircleEndAngle=arrivee
UneForme.CircleKind=3
UneForme.LineColor = RGB(0,0,0)
If Not IsMissing( UneImage ) Then
IOAttribut UneForme, UneImage
end if
If Not IsMissing( sgroupe ) Then
sgroupe.Add(UneForme)
end if
PetitArcDeCercle()=UneForme
End function
function MarqueAngle(xd1 as single, yd1 as single, xangle as single, yangle as single, xd2 as single, yd2 as single, Rentrant as boolean, NombreArc as integer, decale as integer, Optional sgroupe As object) as object
Dim UnObjet As object
Dim pGroupe as object
Dim alpha as single
Dim beta as single
Dim aa as Single
Dim nbforme as Single, toti as integer,i as integer, nombretrait as integer
pGroupe = InitialiseGroupe()
alpha = -CalculeAngle(xangle, yangle, xd1, yd1) * 180 / Pi
beta = -CalculeAngle(xangle, yangle, xd2, yd2) * 180 / Pi
if alpha>beta then Echange alpha,beta
If Rentrant Then
If alpha - beta < 180 Then
beta = beta + 360
Echange alpha,beta
End If
' Else
' If alpha - beta > 180 Then
' beta = beta + 360
' Echange alpha,beta
' End If
End If
nbforme = 0
toti = Int((NombreArc - 1) / 3) + 1
For i = 0 To toti - 1
UnObjet=PetitArcDeCercle(xangle, yangle, alpha*100, beta*100, 1000 + i * 100 + 100 * decale, pGroupe)
nbforme = nbforme + 1
Next i
nombretrait = (NombreArc Mod 3) - 1
If nombretrait = -1 Then nombretrait = 2
aa = -(alpha + beta) / 2
If nombretrait = 1 Then
aa = aa * Pi / 180
InsereLigne(xangle + (400 + 100 * decale) * Cos(aa), yangle + (400 + 100 * decale) * Sin(aa), xangle + (400 + 100 * decale + toti * 150) * Cos(aa), yangle + (400 + 100 * decale + toti * 150) * Sin(aa), pGroupe)
nbforme = nbforme + 1
End If
If nombretrait = 2 Then
ab = (aa - 2) * Pi / 180
InsereLigne(xangle + (400 + 100 * decale) * Cos(ab), yangle + (400 + 100 * decale) * Sin(ab), xangle + (400 + 100 * decale + toti * 150) * Cos(ab), yangle + (400 + 100 * decale + toti * 150) * Sin(ab), pGroupe)
ab = (aa + 2) * Pi / 180
InsereLigne(xangle + (400 + 100 * decale) * Cos(ab), yangle + (400 + 100 * decale) * Sin(ab), xangle + (400 + 100 * decale + toti * 150) * Cos(ab), yangle + (400 + 100 * decale + toti * 150) * Sin(ab), pGroupe)
nbforme = nbforme + 2
End If
UnObjet = GroupeObjet(pGroupe)
if not ismissing(sgroupe) then
sgroupe.add(UnObjet)
end if
MarqueAngle()=UnObjet
End function
Function CalculeAngle(xo as single,yo as single,xxx as single,yyy as single) as double
Dim tang as Double
Dim unAngle as Double
If Abs(xxx - xo) < 0.000001 Then
If yyy > yo Then
UnAngle = Pi / 2
Else
UnAngle = -Pi / 2
End If
Else
If Abs(yyy - yo) < 0.000001 Then
tang = 0
Else
tang = (yyy - yo) / (xxx - xo)
End If
UnAngle = Atn(tang)
If xxx < xo Then
If UnAngle < 0 Then
UnAngle = UnAngle + Pi
Else
UnAngle = UnAngle - Pi
End If
End If
End If
CalculeAngle()=UnAngle
end function
Sub IOAttribut(oShape as object, UneImage as Object)
OAttribut oShape, UneImage.BackgroundColor, ExtraitEpaisseur(UneImage.Helptext), ExtraitTypeTrait(UneImage.Helptext)
End Sub
Function ExtraitEpaisseur(LeTexte As String) As String
Dim LeTexte1
Dim i,j
i=instr(1,LeTexte," ")
j=instr(i,LeTexte,"pt")
LeTexte1 = mid(LeTexte, i+1,j-i-1)
RemplaceVirgulePoint LeTexte1
ExtraitEpaisseur = LeTexte1
End Function
Function ExtraitTypeTrait(LeTexte As String) As String
Select Case Left$(LeTexte, InStr(1, LeTexte, " ") - 1)
Case Chaine("continu")
ExtraitTypeTrait = "msoLineSolid"
Case Chaine("pointille")
ExtraitTypeTrait = "msoLineDash"
case else
ExtraitTypeTrait = ""
End Select
End Function
Function Chaine(uneChaine as String) as String
if BoiteChaineOk = 0 Then
oUneBoite = LoadDialog("OOoGdmath","ChaineForm")
BoiteChaineOk = 1
End if
Chaine = Ressource(oUneBoite.GetControl(lcase(uneChaine)).Model, rLabel)
' oUneBoite.EndExecute()
End Function
Sub CalculeCentreInscrit(x0 as single, y0 as single, x1 as single, y1 as single, x2 as single, y2 as single, xc as single, yc as single)
Dim alpha as Double
Dim beta as Double
Dim xxx as single, xx as single
Dim yyy as single, yy as single
dim aa as Double
alpha = CalculeAngle(x0, y0, x1, y1) * 180 / Pi
beta = CalculeAngle(x0, y0, x2, y2) * 180 / Pi
If alpha > beta Then
If alpha - beta > 180 Then
alpha = alpha - 360
end if
Else
If beta - alpha > 180 Then
beta = beta - 360
end if
End If
aa = (alpha + beta) / 2
xx = x0 + 5000 * Cos(aa * Pi / 180)
yy = y0 + 5000 * Sin(aa * Pi / 180)
alpha = CalculeAngle(x1, y1, x0, y0) * 180 / Pi
beta = CalculeAngle(x1, y1, x2, y2) * 180 / Pi
If alpha > beta Then
If alpha - beta > 180 Then
alpha = alpha - 360
end if
Else
If beta - alpha > 180 Then
beta = beta - 360
end if
End If
aa = (alpha + beta) / 2
xxx = x1 + 5000 * Cos(aa * Pi / 180)
yyy = y1 + 5000 * Sin(aa * Pi / 180)
TrouveIntersection(x0, y0, xx, yy, x1, y1, xxx, yyy, xc, yc)
End Sub
Sub ChangeCouleur(UneImage As Object)
Dim EpaisseurTrait
Dim TexteEpaisseur
oCouleurForm=LoadDialog("OOoGdmath","CouleurForm")
Dim nCount As Integer
Dim sItems As Variant
dim oComboBox as Object
oComboBox = oCouleurForm.getControl("ComboBox1")
nCount = oComboBox.getItemCount()
oComboBox.removeItems( 0, nCount )
sItems = Array( Chaine("pointille"), Chaine("continu"))
oComboBox.addItems( sItems, 0 )
TexteEpaisseur = Trim(Str(ExtraitEpaisseur(UneImage.HelpText)))
If Left(TexteEpaisseur, 1) = "." Then
TexteEpaisseur = "0" & TexteEpaisseur
end if
oCouleurForm.Model.TextField4.Text = TexteEpaisseur
if ExtraitTypeTrait(UneImage.HelpText) = "msoLineSolid" then
ocombobox.Text = Chaine("continu")
else
ocombobox.Text = Chaine("pointille")
End If
oCouleurForm.Model.TextField1.Text=(UneImage.BackgroundColor and RGB(255,0,0))/65536
oCouleurForm.Model.TextField2.Text=(UneImage.BackgroundColor and RGB(0,255,0))/256
oCouleurForm.Model.TextField3.Text=(UneImage.BackgroundColor and RGB(0,0,255))
CouleurForm_MAJLabel()
oCouleurForm.Execute()
if (oCouleurForm.Model.Label8.Label="O") then
UneImage.Backgroundcolor=oCouleurForm.Model.Image1.BackGroundcolor
UneImage.HelpText=oCouleurForm.Model.Image1.HelpText
end if
End Sub
sub DeplaceSelection(posx as long,posy as long,UnObjet as Object)
UnObjet.Position = MakePoint(posx, posy)
end sub
Function InsereCourbe(secArray() as single, n as integer, Optional sgroupe as object, Optional UneImage as object) As object
dim oShape as Object
dim i as integer
dim groupage as object
dim oCoord as New com.sun.star.awt.Point
Redim oCoord(0 to n-1) as New com.sun.star.awt.Point
oShape=oDocumentDessin.createInstance( "com.sun.star.drawing.PolyLineShape")
for i=0 to n-1
oCoord(i).x=secArray(i,0)
oCoord(i).y=secArray(i,1)
next i
oDocumentDessin.DrawPages.GetByIndex(0).add(oShape)
oShape.PolyPolygon=Array(oCoord())
if not ismissing(UneImage) then IOAttribut oShape,UneImage
if not ismissing(sgroupe) then sgroupe.add(oShape)
InsereCourbe=oShape
End Function
Function InsereVecteur(x0,y0,x1,y1, SGroupe, Optional UneImage) as Object
dim unTrait as Object
dim ang as double
dim unPolygone as Object
Dim secArray(0 to 2, 0 to 1) as single
Dim pGroupe as Object
Dim unObjet as Object
pGroupe = InitialiseGroupe()
if ismissing(uneImage) then
unTrait=InsereLigne(x0,y0,x1,y1,pgroupe)
else
unTrait=InsereLigne(x0,y0,x1,y1,pgroupe, uneImage)
end if
ang=CalculeAngle(x0,y0,x1,y1)
secArray(0,0)=x1
secArray(0,1)=y1
secArray(1,0)=x1+200*cos(ang+5*Pi/6)
secArray(1,1)=y1+200*sin(ang+5*Pi/6)
secArray(2,0)=x1+200*cos(ang-5*Pi/6)
secArray(2,1)=y1+200*sin(ang-5*Pi/6)
if ismissing(uneImage) then
unPolygone=InserePolygoneB(secArray(),3,pgroupe)
unPolygone.FillStyle = com.sun.star.drawing.FillStyle.SOLID
unPolygone.FillColor= 0
else
unPolygone=InserePolygoneB(secArray(),3,pgroupe,uneImage)
unPolygone.FillStyle = com.sun.star.drawing.FillStyle.SOLID
unPolygone.FillColor= uneImage.BackgroundColor
end if
UnObjet = GroupeObjet(pGroupe)
sgroupe.add(unObjet)
InsereVecteur=UnObjet
End Function
function InsereLigne(x0 as single, y0 as single, x1 as single, y1 as single, optional SGroupe as object, optional UneImage as object) as object
Dim aPosition as new com.sun.star.awt.Point
Dim TheSize as new com.sun.star.awt.Size
Dim xShape as object
xShape=oDocumentDessin.createInstance("com.sun.star.drawing.LineShape")
' xShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE
xShape.LineWidth = 20
aPosition.X = x0
aPosition.Y = y0
xShape.Position=aPosition
TheSize.width = x1-x0
TheSize.height=y1-y0
xShape.Size=TheSize
' ThisComponent.DrawPage.add( xShape )
oDocumentDessin.DrawPages.GetByIndex(0).add( xShape )
If Not IsMissing( SGroupe ) Then
SGroupe.Add(xShape)
end if
If Not IsMissing(UneImage) Then
IOAttribut(xShape, UneImage)
Else rem ligne ajoutee par Didier Dorange-Pattoret
xShape.LineColor = 0
End if
InsereLigne()=xShape
End Function
Function InserePolygone(secArray(), n as integer, Optional sgroupe as object, Optional UneImage as object) As object
Dim Ligne as object, Shapes as object, UneCourbe as object
dim i, x0 as long, x1 as long, y0 as long, y1 as long
Shapes = InitialiseGroupe()
for i=0 to n-2
x0=secArray(i,0)
y0=secArray(i,1)
x1=secArray(i+1,0)
y1=secArray(i+1,1)
If Not IsMissing(UneImage) Then
InsereLigne x0,y0,x1,y1,Shapes,UneImage
else
InsereLigne x0,y0,x1,y1,Shapes
end if
next i
UneCourbe = GroupeObjet(Shapes)
If Not IsMissing(sgroupe) Then
sgroupe.Add(UneCourbe)
end if
InserePolygone()=UneCourbe
End Function
Function InserePolygoneB(secArray() as single, n as integer, Optional sgroupe as object, Optional UneImage as object) As object
dim oShape as Object
dim i as integer
dim groupage as object
dim oCoord as New com.sun.star.awt.Point
Redim oCoord(0 to n-1) as New com.sun.star.awt.Point
oShape=oDocumentDessin.createInstance( "com.sun.star.drawing.PolyPolygonShape")
for i=0 to n-1
oCoord(i).x=secArray(i,0)
oCoord(i).y=secArray(i,1)
next i
oDocumentDessin.DrawPages.GetByIndex(0).add(oShape)
oShape.PolyPolygon=Array(oCoord())
if not ismissing(UneImage) then IOAttribut(oShape,UneImage)
if not ismissing(sgroupe) then sgroupe.add(oShape)
InserePolygoneB=oShape
End Function
Function InsereQuadrilatere(x0 as single, y0 as single, x1 as single, y1 as single, x2 as single, y2 as single, x3 as single, y3 as single,ts As object, Optional UneImage As object) as object
Dim secArray(0 to 4,0 to 1) as single
secArray(0,0)=x0
secArray(0,1)=y0
secArray(1,0)=x1
secArray(1,1)=y1
secArray(2,0)=x2
secArray(2,1)=y2
secArray(3,0)=x3
secArray(3,1)=y3
secArray(4,0)=x0
secArray(4,1)=y0
if ismissing(UneImage) then
InsereQuadrilatere() = InserePolygone(secArray(), 5, ts)
else
InsereQuadrilatere() = InserePolygone(secArray(), 5, ts, UneImage)
end if
End function
Function InsereQuadrilatereB(x0,y0,x1,y1, Optional sgroupe as object, Optional UneImage as object) As object
Dim secArray(0 to 3,0 to 1) as single
secArray(0,0)=x0
secArray(0,1)=y0
secArray(1,0)=x1
secArray(1,1)=y0
secArray(2,0)=x1
secArray(2,1)=y1
secArray(3,0)=x0
secArray(3,1)=y1
if ismissing(UneImage) then
InsereQuadrilatereB = InserePolygoneB(secArray(), 4, sgroupe)
else
InsereQuadrilatereB = InserePolygoneB(secArray(), 4, sgroupe, UneImage)
end if
End Function
Sub ChargeNomPolice(fparam() as string)
Dim i,j,k
Dim oToolkit as Object
Dim oDevice as Variant
Dim oFontDescriptors As Variant
Dim param() as String
oToolkit = CreateUnoService("com.sun.star.awt.Toolkit")
oDevice = oToolkit.createScreenCompatibleDevice(0, 0)
oFontDescriptors = oDevice.FontDescriptors
Redim param(lbound(oFontDescriptors) to UBound(oFontDescriptors)) as string
thiscomponent.lockcontrollers
dim trouve as Boolean
k=0
for i= LBound(oFontDescriptors) to UBound(oFontDescriptors)
trouve=False
for j=0 to k-1
if param(j)=oFontDescriptors(i).Name then trouve=True
next j
if not trouve then
param(k)=oFontDescriptors(i).Name
k=k+1
end if
next i
thiscomponent.unlockcontrollers
redim fparam(0 to k-1)
for i=0 to k-1
fparam(i)=param(i)
next i
do
trouve=false
for i=0 to k-2
if fparam(i)>fparam(i+1) then
Echange(fparam(i), fparam(i+1))
trouve=True
end if
next i
loop while(trouve)
End Sub
Sub RedresseTexte()
Dim unDocument as Object
Dim unGroupe as Object, leGroupe as Object
Dim uneForme as Object
Dim i, typeForme as String
on error goto erreur
' Cette macro met à 0 l'angle de rotation de tous les textes de la sélection
unDocument=thisComponent
unGroupe=unDocument.CurrentSelection(0)
if unGroupe.ShapeType = "com.sun.star.drawing.GroupShape" Then
for i=0 to unGroupe.Count-1
uneForme = unGroupe(i)
typeForme = uneForme.ShapeType
if uneForme.ShapeType = "com.sun.star.drawing.TextShape" then
uneForme.RotateAngle = 0
end if
next i
Endif
Exit Sub
erreur:
MsgBoxP "message4"
End Sub
Function InsereTexte(UnTexte as string, x0 as single, y0 as single, Optional sgroupe as object, Optional AngleRot, Optional AlignH as integer, Optional AlignV as integer, Optional Mef as Boolean) as object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
Dim xShape as object
Dim oTexte as Object
dim ocursor as Object
if ismissing(Mef) then Mef=False
if Mef then
' On marque tous les objets du dessin
dim i
dim maPage
on error resume next
maPage=oDocumentDessin.DrawPages.GetByIndex(0)
for i=0 to maPage.Count()
maPage(i).Name=maPage(i).Name & "&"
next i
' on met en forme si demande
oCursor=oDocumentTexte.Text.CreateTextCursor
oDocumentTexte.Text.insertString(oCursor,UnTexte,True)
oCursor.goleft(len(UnTexte),True)
oDocumentTexte.CurrentController.Select(oCursor)
xShape=InsereExpression.InsereExpression(oDocumentTexte)
oDocumentTexte.CurrentController.Select(xShape)
CopierColler1()
' Le seul objet non marqué est celui qui vient d'être ajouté, il faut le sélectionner
for i=0 to maPage.Count()
if (right(maPage(i).Name,1)="&") then
maPage(i).Name=left(maPage(i).Name, len(maPage(i).Name)-1)
else
xShape=maPage(i)
end if
next i
else
xShape = oDocumentDessin.createInstance("com.sun.star.drawing.TextShape")
aPoint.x = x0
aPoint.y = y0
aSize.Width = 10
aSize.Height = 10
xShape.Position = aPoint
xShape.Size=aSize
oDocumentDessin.DrawPages.GetByIndex(0).add(xShape)
xShape.String = UnTexte
xShape.Text.CharFontName = OOoGdmath_NomPolice
xShape.Text.CharHeight = OOoGdmath_TaillePolice
xShape.Text.CharPosture = OOoGdmath_ItaliquePolice
xShape.Text.CharUnderline = OOoGdmath_SoulignePolice
GereCaracteresDroits(UnTexte,xShape)
xShape.Text.TextAutoGrowWidth=True
xShape.Text.TextAutoGrowHeight=True
end if
aSize=xShape.Size
if not ismissing(AlignH) then
select case AlignH
case -1
aPoint.x = x0-aSize.Width
case 0
aPoint.x = x0-aSize.Width/2
case 1
aPoint.x = x0
end Select
end if
if not ismissing(AlignV) then
select case AlignV
case -1
aPoint.y = y0-aSize.Height
case 0
aPoint.y = y0-aSize.Height/2
case 1
aPoint.y = y0
end Select
end if
xShape.Position = aPoint
If Not IsMissing(AngleRot) and AngleRot<>0 Then xShape.RotateAngle = AngleRot
If Not IsMissing(sgroupe) Then sgroupe.add(xShape)
InsereTexte()=xShape
end Function
Function InsereTriangleB(x0 as single,y0 as single,x1 as single,y1 as single, x2 as single, y2 as single,optional sgroupe as object, Optional UneImage as object) as object
Dim secArray(0 to 3, 0 to 1) as single
secArray(0,0)=x0
secArray(0,1)=y0
secArray(1,0)=x1
secArray(1,1)=y1
secArray(2,0)=x2
secArray(2,1)=y2
secArray(3,0)=x0
secArray(3,1)=y0
if ismissing(UneImage) then
InsereTriangleB() = InserePolygoneB(secArray(), 4, sgroupe)
else
InsereTriangleB() = InserePolygoneB(secArray(), 4, sgroupe, UneImage)
end if
end function
Function InsereTriangle(x0 as single,y0 as single,x1 as single,y1 as single, x2 as single, y2 as single,optional sgroupe as object, Optional UneImage as object) as object
Dim secArray(0 to 3, 0 to 1) as single
secArray(0,0)=x0
secArray(0,1)=y0
secArray(1,0)=x1
secArray(1,1)=y1
secArray(2,0)=x2
secArray(2,1)=y2
secArray(3,0)=x0
secArray(3,1)=y0
if ismissing(UneImage) then
InsereTriangle() = InserePolygone(secArray(), 4, sgroupe)
else
InsereTriangle() = InserePolygone(secArray(), 4, sgroupe, UneImage)
end if
end function
Function LoadDialog(Libname as String, DialogName as String) ', Optional oLibContainer) rem charge une boite de dialogue
Dim oLib,oLibDialog,oRuntimeDialog,oDialogModel,oVar,oVar1 as Object
Dim langue As New com.sun.star.lang.Locale
DialogLibraries.LoadLibrary(LibName)
oLib = DialogLibraries.GetByName(Libname)
oLibDialog = oLib.GetByName(DialogName)
oRuntimeDialog = CreateUnoDialog(oLibDialog)
oDialogModel=oRuntimeDialog.Model
InitialiseForm(oRuntimeDialog)
LoadDialog() = oRuntimeDialog
if BasicLibraries.Standard.hasByName("DmOptions") Then
select case iLang
case 0
langue.Language = "fr"
langue.Country = "FR"
case 1
langue.Language = "en"
langue.Country = "US"
case 2
langue.Language = "de"
langue.Country = "DE"
End Select
oRuntimeDialog.Model.ResourceResolver.setCurrentLocale(langue, True)
End If
if DialogName <> "ChaineForm" And DialogName <> "NommageForm" Then
laBoitedeDialogue = oRuntimeDialog
End If
End Function
Function MakePoint( x As Long, y As Long ) As com.sun.star.awt.Point
Dim aPoint As New com.sun.star.awt.Point
aPoint.x = x
aPoint.y = y
MakePoint() = aPoint
End Function
function MarqueAngleDroit(xd as single, yd as single, xs as single, ys as single, sgroupe As object,Optional UneImage as Object) as object
Dim pgroupe As object
Dim alpha as Double
Dim unObjet as Object
pGroupe=initialisegroupe()
alpha = CalculeAngle(xd, yd, xs, ys)
if ismissing(uneImage) then
InsereLigne(xd + 200 * Cos(alpha), yd + 200 * Sin(alpha), xd + 200 * (Cos(alpha) - Sin(alpha)), yd + 200 * (Sin(alpha) + Cos(alpha)), pgroupe)
InsereLigne(xd - 200 * Sin(alpha), yd + 200 * Cos(alpha), xd + 200 * (Cos(alpha) - Sin(alpha)), yd + 200 * (Sin(alpha) + Cos(alpha)), pgroupe)
else
InsereLigne(xd + 200 * Cos(alpha), yd + 200 * Sin(alpha), xd + 200 * (Cos(alpha) - Sin(alpha)), yd + 200 * (Sin(alpha) + Cos(alpha)), pgroupe, uneImage)
InsereLigne(xd - 200 * Sin(alpha), yd + 200 * Cos(alpha), xd + 200 * (Cos(alpha) - Sin(alpha)), yd + 200 * (Sin(alpha) + Cos(alpha)), pgroupe, uneImage)
End if
UnObjet = GroupeObjet(pGroupe)
if not ismissing(sgroupe) then
sgroupe.add(UnObjet)
end if
MarqueAngleDroit()=UnObjet
End function
sub PointInsertion(posx,posy)
posx=3000
posy=3000
end sub
function TraceBissectrice(xx1 as single, yy1 as single, xxx0 as single, yyy0 as single, xx2 as single, yy2 as single, sgroupe as object, Optional ProlongeBissectriceS as boolean, Optional ProlongeBissectriceI as boolean, Optional xci as integer, Optional yci as integer) as object
dim pgroupe as object
dim xx0, yy0
dim alpha,beta
dim xx,yy
dim angleh
Dim seg1 as Object, seg2 as Object, seg3 as Object, seg4 as Object
Dim unObjet as Object
Dim lecodage
dim aa
if (ismissing(ProlongeBissectriceS)) then ProlongeBissectriceS=False
if (ismissing(ProlongeBissectriceI)) then ProlongeBissectriceI=False
pgroupe=InitialiseGroupe()
xx0 = xxx0
yy0 = yyy0
alpha = CalculeAngle(xx0, yy0, xx2, yy2) * 180 / Pi
beta = CalculeAngle(xx0, yy0, xx1, yy1) * 180 / Pi
If alpha > beta Then
If alpha - beta > 180 Then
alpha = alpha - 360
end if
Else
If beta - alpha > 180 Then
beta = beta - 360
end if
End If
aa = (alpha + beta) / 2
xx = xx0 + 5000 * Cos(aa * Pi / 180)
yy = yy0 + 5000 * Sin(aa * Pi / 180)
If ProlongeBissectriceS Then
angleh = CalculeAngle(xx0, yy0, xx, yy)
xx0 = xx0 - 5000 * Cos(angleh)
yy0 = yy0 - 5000 * Sin(angleh)
End If
If ProlongeBissectriceI Then
angleh = CalculeAngle(xx0, yy0, xx, yy)
If xx0 > xx Or yy0 > yy Then
If xci < xx Or yci < yy Then
xx = xci + 5000 * Cos(angleh)
yy = yci + 5000 * Sin(angleh)
End If
End If
If xx0 < xx Or yy0 < yy Then
If xci > xx Or yci > yy Then
xx = xci + 5000 * Cos(angleh)
yy = yci + 5000 * Sin(angleh)
End If
End If
End If
InsereLigne(xx0, yy0, xx, yy, pgroupe)
If (CInt(CodageALabel2) <> 10) Then
Seg1 = InsereLigne(xx0, yy0, xx1, yy1)
Seg1.LineColor = RGB(0, 0, 255)
Seg2 = InsereLigne(xx0, yy0, xx, yy)
Seg2.LineColor = RGB(0, 0, 255)
Seg3 = InsereLigne(xx0, yy0, xx2, yy2)
Seg3.LineColor = RGB(255, 0, 0)
Seg4 = InsereLigne(xx0, yy0, xx + 1, yy)
Seg4.LineColor = RGB(255, 0, 0)
AfficheCodageAForm
oDocumentDessin.DrawPages.GetByIndex(0).remove(Seg1)
oDocumentDessin.DrawPages.GetByIndex(0).remove(Seg2)
oDocumentDessin.DrawPages.GetByIndex(0).remove(Seg3)
oDocumentDessin.DrawPages.GetByIndex(0).remove(Seg4)
lecodage = CInt(CodageALabel2)
If (lecodage = 10) Then lecodage = 0
End If
If (CInt(CodageALabel2) = 10) Then
lecodage = lecodage + 1
If lecodage = 10 Then
lecodage = 1
end if
End If
If (CodageALabel2 <> "11") Then
MarqueAngle(xx1, yy1, xx0, yy0, xx, yy, (aa > 180), lecodage, 0, pgroupe)
MarqueAngle(xx, yy, xx0, yy0, xx2, yy2, (aa > 180), lecodage, 1, pgroupe)
End If
UnObjet=GroupeObjet(pgroupe)
if not ismissing(sgroupe) then
sgroupe.add(UnObjet)
end if
TraceBissectrice()=UnObjet
End function
function TraceParallele(xx0, yy0, xx1, yy1, xx2, yy2, optional sgroupe as object) as object
UnAngle = CalculeAngle(xx0, yy0, xx1, yy1)
ll = 4000
if not ismissing(sgroupe) then
UnObjet=InsereLigne(xx2 - ll * Cos(UnAngle), yy2 - ll * Sin(UnAngle), xx2 + ll * Cos(UnAngle), yy2 + ll * Sin(UnAngle), sgroupe)
else
UnObjet=InsereLigne(xx2 - ll * Cos(UnAngle), yy2 - ll * Sin(UnAngle), xx2 + ll * Cos(UnAngle), yy2 + ll * Sin(UnAngle))
end if
TraceParallele()=UnObjet
End function
function TracePerpendiculaire(xx0 as Single, yy0 as Single, xx1 as Single, yy1 as Single, xx2 as Single, yy2 as Single, optional sgroupe as object) as object
dim pgroupe as object
Dim xx as Single, yy as Single
Dim unAngle as Double
pGroupe=InitialiseGroupe()
TrouvePiedHauteur(xx0, yy0, xx1, yy1, xx2, yy2, xx, yy)
UnAngle = CalculeAngle(xx0, yy0, xx1, yy1) + Pi / 2
InsereLigne(xx - 5000 * Cos(UnAngle), yy - 5000 * Sin(UnAngle), xx + 5000 * Cos(UnAngle), yy + 5000 * Sin(UnAngle), pgroupe)
MarqueAngleDroit(xx, yy, MIif(xx = xx0, xx1, xx0), MIif(yy = yy0, yy1, yy0), pgroupe)
UnObjet=GroupeObjet(pGroupe)
if not ismissing(sgroupe) then
sgroupe.add(UnObjet)
end if
TracePerpendiculaire()=UnObjet
End function
Function SelectionneForme(oDocument as Object, uneForme as Object) as Boolean
on error goto fin
SelectionneForme=False
oDocument.CurrentController.Select(uneForme)
SelectionneForme=True
fin:
end Function
Sub ExtraitPoint(texte$, i, np$, xx, yy, Optional txx as String, Optional tyy as string)
Dim a, b, c, coord1$, coord2$, num, den
if ismissing(txx) then txx=""
if ismissing(tyy) then tyy=""
a = InStr(i, texte$, "(")
' If a = 0 Or a - i > 1 Then
If a = 0 Then
i = -1
Else
b = InStr(a, texte$, ";")
If b = 0 Then
i = -1
Else
c = InStr(b, texte$, ")")
If c = 0 Then
i = -1
Else
np$ = ""
If a > 1 Then np$ = Left(texte$, a - 1)
coord1$ = Mid$(texte$, a + 1, b - a - 1)
If txx <> "" Then txx = coord1$
RemplaceVirgulePoint coord1$
coord2$ = Mid$(texte$, b + 1, c - b - 1)
If tyy <> "" Then tyy = coord2$
RemplaceVirgulePoint coord2$
If InStr(1, coord1$, "/") <> 0 Then
AACExtraitNDF coord1$, num, den
xx = Val(num) / Val(den)
Else
xx = Val(coord1$)
End If
If InStr(1, coord2$, "/") <> 0 Then
AACExtraitNDF coord2$, num, den
yy = Val(num) / Val(den)
Else
yy = Val(coord2$)
End If
i = c + 1
End If
End If
End If
End Sub
Sub OAttribut(oShape As Object, Couleur, epaisseur, style)
Dim i
if oShape.ShapeType = "com.sun.star.drawing.GroupShape" Then
for i=0 to oShape.Count-1
OAttribut(oShape(i), Couleur, epaisseur, style)
next i
else
OAttributB(oShape, Couleur, epaisseur, style)
End if
End Sub
Sub OAttributB(oShape as Object, Couleur, epaisseur, style)
Dim mesTirets as new com.sun.star.drawing.LineDash
with mesTirets
.Style = com.sun.star.drawing.DashStyle.RECT
.Dots = 0
.DotLen = 0
.Dashes = 1
.DashLen = 100
.Distance = 100
End With
if (style="msoLineSolid") then oShape.LineStyle = com.sun.star.drawing.LineStyle.SOLID
if (style="msoLineDash") then
oShape.LineStyle = com.sun.star.drawing.LineStyle.DASH
oShape.LineDash = mesTirets
end if
oShape.LineWidth = val(epaisseur)*17639/500
oShape.LineColor = Couleur
End Sub
Sub ExtraitVecteur(texte$, i, x0, y0, x1, y1)
Dim param() as string
i=-1
if left(texte$,1)="{" and right(texte$,1)="}" then
i=ChargeParametre(mid(texte$,2,len(texte$)-2), param(), ";")
RemplaceVirgulePoint param(0)
RemplaceVirgulePoint param(1)
RemplaceVirgulePoint param(2)
RemplaceVirgulePoint param(3)
x0 = Val(param(0))
y0 = Val(param(1))
x1 = Val(param(2))
y1 = Val(param(3))
End If
End Sub
Sub ExtraitSegment(texte$, i, x0, y0, x1, y1)
Dim param() as string
i=-1
if left(texte$,1)="[" and right(texte$,1)="]" then
i=ChargeParametre(mid(texte$,2,len(texte$)-2), param(), ";")
RemplaceVirgulePoint param(0)
RemplaceVirgulePoint param(1)
RemplaceVirgulePoint param(2)
RemplaceVirgulePoint param(3)
x0 = Val(param(0))
y0 = Val(param(1))
x1 = Val(param(2))
y1 = Val(param(3))
End If
End Sub
Sub MarqueExtremites(x0, y0, x1, y1, Shapes as Object, Optional trait1 As object, Optional trait2 As object)
Dim xm, ym, r
xm = (x0 + x1) / 2
ym = (y0 + y1) / 2
r = Sqr((x0 - xm) * (x0 - xm) + (y0 - ym) * (y0 - ym))
trait1=InsereLigne(x0 - 100 * (y0 - ym) / r, y0 + 100 * (x0 - xm) / r, x0 + 100 * (y0 - ym) / r, y0 - 100 * (x0 - xm) / r, Shapes)
trait2=InsereLigne(x1 - 100 * (y0 - ym) / r, y1 + 100 * (x0 - xm) / r, x1 + 100 * (y0 - ym) / r, y1 - 100 * (x0 - xm) / r, Shapes)
End Sub
Sub ExtraitDroite(texte$, i, a, b, c, eqdroite$)
Dim ffx$, x1, y1, x2, y2, Defini, ffy$
If UCase(Left(texte$, 1)) = "Y" Then
' y=f(x)
ffx$ = Right(texte$, Len(texte$) - InStr(1, texte$, "="))
RemplaceTexte ffx$, "x", "(-1)"
x1 = -1
y1 = CalculeFonction(ffx$, Defini)
ffx = Right(texte$, Len(texte$) - InStr(1, texte$, "="))
RemplaceTexte ffx$, "x", "(+1)"
x2 = 1
y2 = CalculeFonction(ffx$, Defini)
Else
'x=f(y)
If UCase(Left(texte$, 1)) = "X" Then
ffy$ = Right(texte$, Len(texte$) - InStr(1, texte$, "="))
RemplaceTexte ffy$, "y", "(-1)"
y1 = -1
x1 = CalculeFonction(ffy$, Defini)
ffy$ = Right(texte$, Len(texte$) - InStr(1, texte$, "="))
RemplaceTexte ffy$, "y", "(+1)"
y2 = 1
x2 = CalculeFonction(ffy$, Defini)
Else
i = -1
End If
End If
If i <> -1 Then
If x1 <> x2 Then
a = (y1 - y2) / (x1 - x2)
b = -1
c = y1 - a * x1
Else
a = 1
b = 0
c = -x1
End If
eqdroite$ = texte$
End If
End Sub
Function getModuleText(LibN As String, ModN As String) As String
Dim LibContainer As Object
Dim Lib1 As Object
dim texte as String
dim stexte as string
dim atexte as String
LibContainer = GlobalScope.BasicLibraries
Lib1 = LibContainer.getByName(LibN)
if Lib1.hasByName(ModN) then
stexte = Lib1.getByName(ModN)
atexte = stexte
if instr(1, stexte, "OOoGdmath_NomPolice") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_NomPolice = " & chr(34) & "Times New Roman" & chr(34) & chr(10)
if instr(1, stexte, "OOoGdmath_TaillePolice") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_TaillePolice = 12" & chr(10)
if instr(1, stexte, "OOoGdmath_ItaliquePolice") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_ItaliquePolice = 2" & chr(10)
if instr(1, stexte, "OOoGdmath_SoulignePolice") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_SoulignePolice = 0" & chr(10)
if instr(1, stexte, "OOoGdmath_GrasPolice") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_GrasPolice = 0" & chr(10)
if instr(1, stexte, "OOoGdmath_SensNommage") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_SensNommage = 0" & chr(10)
if instr(1, stexte, "OOoGdmath_TypeNommage") = 0 Then stexte = stexte & chr(10) & "Public Const OOoGdmath_TypeNommage = 0" & chr(10)
if instr(1, stexte, "Sub OOoGdmath()") = 0 Then stexte = stexte & chr(10) & chr(10) & "Sub OOoGdmath()" & chr(10) & "Print " & chr(34) & "OOoGdmath" & chr(34) & chr(10) & "End Sub" & chr(10)
if atexte <> stexte then saveModuleText LibN, ModN, stexte
else
texte = chr(10)
texte = texte & "Public Const OOoGdmath_NomPolice = " & chr(34) & "Times New Roman" & chr(34) & chr(10)
texte = texte & "Public Const OOoGdmath_TaillePolice = 12" & chr(10)
texte = texte & "Public Const OOoGdmath_ItaliquePolice = 2" & chr(10)
texte = texte & "Public Const OOoGdmath_SoulignePolice = 0" & chr(10)
texte = texte & "Public Const OOoGdmath_GrasPolice = 0" & chr(10)
texte = texte & "Public Const OOoGdmath_SensNommage = 0" & chr(10)
texte = texte & "Public Const OOoGdmath_TypeNommage = 0" & chr(10)
texte = texte & chr(10) & chr(10) & "Sub OOoGdmath()" & chr(10)
texte = texte & "Print " & chr(34) & "OOoGdmath" & chr(34) & chr(10)
texte = texte & "End Sub" & chr(10)
Lib1.InsertByName(ModN, texte)
stexte = texte
end if
getModuleText() = stexte
End Function
' returns true if successful
Function saveModuleText(LibN As String, ModN As String, newText As String) As Boolean
Dim LibContainer As Object
Dim Lib1 As Object
LibContainer = GlobalScope.BasicLibraries
Lib1 = LibContainer.getByName(LibN)
if Lib1.hasByName(ModN) then
Lib1.replacebyName(ModN, newText)
saveModuleText = true
else
Lib1.insertByName(ModN, "")
saveModuleText = saveModuleText(LibN, ModN, newText)
end if
End Function
Sub RemplaceX(texte$, X)
Dim tx
RemplaceTexte texte$, "exp", "esp"
tx = InStr(1, UCase(texte$), "X")
While tx > 0
texte$ = Left$(texte$, tx - 1) + "(" + Str(X) + ")" + Right$(texte$, Len(texte$) - tx)
tx = InStr(tx + 1, UCase(texte$), "X")
Wend
RemplaceTexte texte$, "esp", "exp"
End Sub
Sub RemplaceY(texte, X)
Dim tx
tx = InStr(1, UCase(texte), "Y")
While tx > 0
texte = Left(texte, tx - 1) + X + Right(texte, Len(texte) - tx)
tx = InStr(tx + 1, UCase(texte), "Y")
Wend
End Sub
Sub RemplaceT(texte$, X)
Dim tx
RemplaceTexte texte$, "tan", "xan"
tx = InStr(1, UCase(texte$), "T")
While tx > 0
texte$ = Left(texte$, tx - 1) + X + Right(texte$, Len(texte$) - tx)
tx = InStr(tx + 1, UCase(texte$), "T")
Wend
RemplaceTexte texte$, "xan", "tan"
End Sub
Sub CalculeCoordonnees(xx, yy, posx, posy, dx, dy, angleaxe)
Dim xxx, yyy
xxx = posx + xx * dx + yy * dy * Cos(angleaxe)
yyy = posy - yy * dy * Sin(angleaxe)
xx = xxx
yy = yyy
End Sub
Sub RemplissageForme(zone1, couleur, Transparence)
zone1.zOrder = -1
zone1.LineStyle = com.sun.star.drawing.LineStyle.NONE
zone1.FillStyle = com.sun.star.drawing.FillStyle.SOLID
zone1.FillColor = couleur
zone1.FillTransparence = Transparence
End Sub
Function NombreTexte(Debut, texte1, texte2) As Integer
Dim a, i
a = Debut
i = 0
While (a > 0)
a = InStr(a, texte1, texte2)
If a > 0 Then
a = a + 1
i = i + 1
End If
If texte2 = "\s\do" Then
If a > 0 Then
If Mid(texte1, a + 6, 2) = "\f" Then
i = i - 1
End If
End If
End If
Wend
NombreTexte = i
End Function
Function MIif(unEtat as Boolean, valeur1, valeur2) as variant
If unEtat then
MIif() = valeur1
Else
MIif() = valeur2
End If
End Function
Sub TraceLigneGroupe(unGroupe as Object, position as String, uneImage As Object)
Dim Group as Object
Dim px,py,lx,ly
Dim i
Group = oDocumentDessin.DrawPages.GetByIndex(0).group(unGroupe)
lx = Group.Size.Width
ly = Group.Size.Height
px = Group.Position.x
py = Group.Position.y
oDocumentDessin.DrawPages.GetByIndex(0).ungroup(Group)
for i=1 to len(position)
select case mid(position, i, 1)
case "s"
InsereLigne px-lx*0.1, py+ly+100, px+lx+lx*0.1, py+ly+100, unGroupe, uneImage
case "n"
InsereLigne px-lx*0.1, py, px+lx+lx*0.1, py, unGroupe, uneImage
case "t"
InsereLigne px, py+ly+100, px+lx, py+ly+100, unGroupe, uneImage
End Select
Next i
End Sub
Sub NormaliseCoordonnees(x, y, x1, y1, x0, y0, x2, y2, Optional sens)
Dim n
if ismissing(sens) then sens = 300
n = sqr((2 * x0 - x1 - x2) ^ 2 + (2 * y0 - y1 - y2) ^ 2)
x = (2 * x0 - x1 - x2) / n
y = (2 * y0 - y1 - y2) / n
x = x0 + sens * x
y = y0 + sens * y
End Sub
Function MVal(unTexte as string)
RemplaceVirgulePoint unTexte
Mval = val(unTexte)
End Function
</script:module><?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script"; script:name="MultiCode" script:language="StarBasic">'OOoGdmath
'Copyright (C) 2005-2009 Gilles Daurat
'This program is free software; you can redistribute it and/or
'modify it under the terms of the GNU General Public License
'as published by the Free Software Foundation; either version 2
'of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
Option Explicit
Dim oMultiForm as object
Sub Main
oMultiForm = LoadDialog("OOoGdmath","MultiForm")
ChangeTitreDialog(oMultiForm)
' RestaureForm(oMultiForm)
oMultiForm.Execute()
End Sub
Private Sub MultiCode_CheckBox1_Click()
oMultiForm.Model.TextBox4.Enabled = oMultiForm.Model.CheckBox1.State
End Sub
Private Sub MultiCode_CheckBox2_Click()
oMultiForm.Model.TextBox3.Enabled = oMultiForm.Model.CheckBox2.State
End Sub
Private Sub MultiCode_CommandButton1_Click()
Dim MM, m
dim param() as string
DIM prod as string
oMultiForm.EndExecute()
sauveForm(oMultiForm)
prod=oMultiForm.Model.TextBox1.Text
if val(prod)<>0 and instr(1,prod,"*")>0 then
ChargeParametre prod,param(),"*"
MM = param(0)
RemplaceVirgulePoint MM
MM=trim(str(val(MM))) 'Ignorieren unzulässiger Zeichen
sci2dec MM
m = param(1)
RemplaceVirgulePoint m
m=trim(str(val(m))) 'Ignorieren unzulässiger Zeichen
sci2dec m
if val(MM)*val(m)<>0 then
InsereMultiplication MM, m, MIif(oMultiForm.Model.CheckBox1.State, oMultiForm.Model.TextBox4.Text,""),MIif(oMultiForm.Model.CheckBox2.State, oMultiForm.Model.TextBox3.Text,""), oMultiForm.Model.CheckBox3.State
end if
end if
End Sub
Private Sub MultiCode_CommandButton2_Click()
oMultiForm.EndExecute()
End Sub
Private Sub MultiCode_Image1_Click()
ChangeCouleur oMultiForm.Model.Image1
End Sub
Private Sub MultiCode_TextBox4_Change()
oMultiForm.Model.TextBox4.Text = Left$(oMultiForm.Model.TextBox4.Text, 1)
End Sub
Private Sub MultiCode_TextBox3_Change()
oMultiForm.Model.TextBox3.Text = Left$(oMultiForm.Model.TextBox3.Text, 1)
End Sub
Sub InsereMultiplication(MM, m, OperationTrou,CarDecalage,Intermediaire)
Dim l,h, nchiffre1, nchiffre2, nchiffre3, piz, i, c, mp$, j, mpp$, Resultat$, pos_insere
Dim Shapes as Object
DIM vert as boolean
InitialiseDessin(False)
Shapes=InitialiseGroupe()
DimensionTexte "8",12,l,h
vert= oMultiForm.Model.OptionButton1.State
nchiffre1 = InStr(1, MM, ".")
If nchiffre1 > 0 Then nchiffre1 = Len(MM) - nchiffre1
nchiffre2 = InStr(1, m, ".")
If nchiffre2 > 0 Then nchiffre2 = Len(m) - nchiffre2
If nchiffre1 > 0 Then MM = Left$(MM, Len(MM) - 1 - nchiffre1) & Right$(MM, nchiffre1)
If nchiffre2 > 0 Then m = Left$(m, Len(m) - 1 - nchiffre2) & Right$(m, nchiffre2)
AfficheTexte 10, 1, MM, nchiffre1 > 0, nchiffre1, Shapes,l,h
if vert then 'vertikal
AfficheTexte 10 - max(Len(m), Len(MM)), 2, Chr(215), False, 0, Shapes,l,h
AfficheTexte 10, 2, m, nchiffre2 > 0, nchiffre2, Shapes,l,h
pos_insere=10
else 'horizontal
AfficheTexte 11, 1, Chr(215), False, 0, Shapes,l,h
AfficheTexte 11+len(m), 1, m, nchiffre2 > 0, nchiffre2, Shapes,l,h
pos_insere=11+len(m)
endif
TraceLigneGroupe Shapes, "s", oMultiForm.Model.Image1, 0.05
nchiffre3 = nchiffre1 + nchiffre2
While Left$(m, 1) = "0"
m = Right$(m, Len(m) - 1)
Wend
While Left$(MM, 1) = "0"
MM = Right$(MM, Len(MM) - 1)
Wend
piz = 0
For i = 1 To Len(m)
c = Mid$(m, Len(m) + 1 - i, 1)
mp$ = trim(Str(Val(MM) * Val(c)))
If mp$ = "0" Then
piz = piz + 1
Else
If OperationTrou <> "" Then RemplaceChiffreCaractere mp$, OperationTrou
If Len(m) = 1 Then
if vert then
AfficheTexte 11 - i, i + 2 - piz+0.3, mp$, nchiffre3 > 0, nchiffre3, Shapes,l,h
else
AfficheTexte 12+len(m) - i, i + 1 - piz+0.3, mp$, nchiffre3 > 0, nchiffre3, Shapes,l,h
end if
'AfficheTexte 11 - i, i + 2 - piz+0.3, mp$, nchiffre3 > 0, nchiffre3, Shapes,l,h
Else
if Intermediaire then
if OperationTrou <> "" Then
CarDecalage = OperationTrou
else
CarDecalage = "0"
End if
End if
If CarDecalage <> "" Then
For j = 1 To i - 1
mp$ = mp$ & CarDecalage
Next j
if vert then
AfficheTexte 10, i + 2 - piz+0.3, mp$, False, 0, Shapes,l,h
else
AfficheTexte 11+len(m), i + 1 - piz+0.3, mp$, False, 0, Shapes,l,h
end if
Else
if vert then
AfficheTexte 11 - i, i + 2 - piz+0.3, mp$, False, 0, Shapes,l,h
else
AfficheTexte 12+len(m) - i, i + 1 - piz+0.3, mp$, False, 0, Shapes,l,h
end if
End If
End If
End If
Next i
If Len(m) > 1 Then
Resultat$ = Str(Val(MM) * Val(m))
Resultat$ = Right$(Resultat$, Len(Resultat$) - 1)
If OperationTrou <> "" Then RemplaceChiffreCaractere Resultat$, OperationTrou
TraceLigneGroupe Shapes, "t", oMultiForm.Model.Image1, 0
if vert then
AfficheTexte 10, Len(m) + 3 - piz+0.6, Resultat$, nchiffre1 + nchiffre2 > 0, nchiffre1 + nchiffre2, Shapes,l,h
else
AfficheTexte 11+len(m), Len(m) + 2 - piz+0.6, Resultat$, nchiffre1 + nchiffre2 > 0, nchiffre1 + nchiffre2, Shapes,l,h
end if
End If
piz=0
For i = 1 To Len(m)
c = Mid$(m, Len(m) + 1 - i, 1)
mp$ = trim(Str(Val(MM) * Val(c)))
If mp$ = "0" Then
piz = piz + 1
Else
If OperationTrou <> "" Then RemplaceChiffreCaractere mp$, OperationTrou
If Len(m) > 1 Then
If Intermediaire Then
mpp$ = " = " & MM & " " & chr(215) & " " & c
If CarDecalage<>"" Then
For j = 1 To i - 1
mpp$ = mpp$ & "0"
Next j
End If
if vert then
InsereTexte mpp$, pos_insere*l*2, (i + 2 - piz+0.3)*h, Shapes,0,1,1
else
InsereTexte mpp$, pos_insere*l*2, (i + 1 - piz+0.3)*h, Shapes,0,1,1
end if
End If
End If
End If
Next i
Dim aPoint As New com.sun.star.awt.Point
Dim TheSize as new com.sun.star.awt.Size
Dim Group as Object
aPoint.x=3000
aPoint.y=3000
Group = GroupeObjet(Shapes)
Group.Position=aPoint
TermineDessin()
End Sub
</script:module>
| Mail converted by MHonArc 2.6.19+ | http://listengine.tuxfamily.org/ |