Keskustelu: Koodit: VB6: Kirjainjärjestyksen muunnin 1.2

' koodia saa VAPAASTI hyödyntää omaan käyttöönsä!

Option Explicit
Private Function Poista_Alku_Spacet(merkkijono As String) As String
Dim palaute As String
palaute = merkkijono
While Left(palaute, 1) = " "
palaute = Right(palaute, Len(palaute) - 1)
Wend
Poista_Alku_Spacet = palaute
End Function
Private Sub muunto()
Dim chara As String * 1
Dim j As Integer
Dim leikkuu As String
Dim sana As String

leikkuu = Poista_Alku_Spacet(RichTextBox1.Text)
If InStr(1, leikkuu, " ") > 0 Then
For j = 0 To Len(leikkuu)
chara = Mid(leikkuu, j + 1, 1)
If chara <> " " Then
sana = sana + chara
Else
muuta (sana)
sana = ""
End If
Next
Else
muuta (leikkuu)
End If
End Sub

Private Sub muuta(sana As String)
Dim muuta As String
Dim sanalen As Integer
Dim eka As String * 1
Dim loppu As String
Dim temp() As String * 1
Dim jotaulu() As Integer
Dim j As Integer
Dim i As Integer
Dim nummi As Integer
Dim onjo As Boolean
Dim muunnettu As String

eka = Left(sana, 1)
loppu = Right(sana, 1)
j = 2
Do
If Asc(loppu) > 32 And Asc(loppu) < 48 Then
loppu = Right(sana, j)
j = j + 1
Else
Exit Do
End If
Loop Until 1
sanalen = Len(sana) - j
If RichTextBox2.Text <> "" Then
RichTextBox2.Text = RichTextBox2.Text + " "
End If
If sanalen < 2 Then
RichTextBox2.Text = RichTextBox2.Text + sana
Exit Sub
End If
ReDim temp(sanalen)
ReDim jotaulu(sanalen)
For j = 0 To sanalen - 1 Step 1
Randomize
nummi = Int((sanalen * Rnd) + 1)    'Arvotaan luku jokaon sananpituus -2 ja vähintään 1
onjo = False                        'Toivotaan että lukua ei vielä ole taulussa.

For i = 0 To j Step 1               'Tarkistetaan onko luku taulussa
If jotaulu(i) = nummi Then          'Jos luku on...
j = j - 2                           'arvonta kyseisen luvun osalta suoritetaan uudelleen.
onjo = True                         'Merkitään että esiintyi
Exit For                            'Poistutaan tästä silmukasta
End If
Next
DoEvents
If onjo = False Then
jotaulu(i) = nummi
temp(j) = Mid(sana, nummi + 1, 1)
End If
Next
For j = 0 To sanalen - 1 Step 1
muunnettu = muunnettu + temp(j)
Next
RichTextBox2.Text = RichTextBox2.Text + eka + muunnettu + loppu
End Sub


Private Sub Command1_Click()
On Error GoTo virhe
If Check1.Value = Checked Then
RichTextBox2.Text = ""
If RichTextBox1.Text <> "" Then
muunto
Clipboard.SetText (RichTextBox2.Text)
End If
Else
If RichTextBox1.Text <> "" Then
muunto
Clipboard.SetText (RichTextBox2.Text)
End If
End If
Exit Sub
virhe:
MsgBox "Error"
End Sub

Private Sub Command2_Click()
On Error GoTo virhe

    Dim filu As String

    With CommonDialog1
        .DialogTitle = "Tallenna nimellä..."
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "Muunnetut sanalistat (*.kjm)|*.kjm"
        .ShowSave
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        filu = .FileName
    End With
    Form1.RichTextBox2.SaveFile filu
    Exit Sub

virhe:
MsgBox "Ei voi tallentaa tiedostoa " & filu & ".", , "Virhe"
End Sub

Private Sub Command3_Click()
On Error GoTo virhe

    Dim filu As String


    With CommonDialog1
        .DialogTitle = "Avaa"
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "Muunnetut sanalistat (*.kjm)|*.kjm"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        filu = .FileName
    End With
    Form1.RichTextBox2.LoadFile filu
    Exit Sub

virhe:
MsgBox "Tiedostoa " & filu & " ei löydy.", , "Virhe"
End Sub

Private Sub Form_Load()
On Error GoTo virhe
Form1.BackColor = &H80FF&
Form1.Height = 4000   'Asetetaan Formin määritteet
Form1.Width = 5200
Form1.Left = 3300
Form1.Top = 2600
Form1.Caption = "Kirjainjärjestyksen muunnin, versio 2.0"
RichTextBox1.BackColor = &H80C0FF
RichTextBox1.Height = 1400   'TextBoxin määritteet
RichTextBox1.Width = 4800
RichTextBox1.Left = 160
RichTextBox1.Top = 120
RichTextBox1.Text = ""
RichTextBox2.BackColor = &H80C0FF
RichTextBox2.Height = 1400  'Labelin määritteet
RichTextBox2.Width = 4800
RichTextBox2.Left = 160
RichTextBox2.Top = 1700
RichTextBox2.BorderStyle = 1
RichTextBox2.Enabled = False
RichTextBox2.Text = ""
Command1.Height = 400 'Painikkeen määritteet
Command1.Width = 1000
Command1.Left = 1760
Command1.Top = 3200
Command1.Caption = "&Muunna"
Command2.Height = 400 'Tallenna-painikkeen määritteet
Command2.Width = 1000
Command2.Left = 2860
Command2.Top = 3200
Command2.Caption = "&Tallenna"
Command3.Height = 400 'Lataa-painikkeen määritteet
Command3.Width = 1000
Command3.Left = 3960
Command3.Top = 3200
Command3.Caption = "&Lataa"
Check1.BackColor = &H80FF&
Check1.Height = 400   'CheckBoxin määritteet
Check1.Width = 1400
Check1.Left = 160
Check1.Top = 3180
Check1.Caption = "Tyhjennä automaattisesti"
Exit Sub
virhe:
MsgBox "Error"
End Sub