Keskustelu: Koodit: VB6: Kontrollin tekstin vaihtaja

'|----------------------------------------------------------------------|
'| Tekstinvaihtaja                                                      |
'|                                                                      |
'| Kirjoittanut Kimmo Kenttälä                                          |
'|                                                                      |
'| Tämä ohjelma vaihtaa kontrollin (esim. nappi) tekstin toiseksi      |
'| valmiiksi määriteltyjen ohjeiden mukaan ja palauttaa sammuessaan     |
'| vanhan tekstin takaisin.                                             |
'|                                                                      |
'| Joitain tässä ohjelmassa esiintyviä temppuja varten on haettu tietoa |
'| Ohjelmointiputkan (www.ohjelmointiputka.net) koodivinkeistä.         |
'|                                                                      |
'|----------------------------------------------------------------------|

'Määritellään tarvittavat jutut
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private Type POINTAPI
        x As Long
        y As Long
End Type

Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETTEXT = &HC

Private VaihdettujenMäärä As Integer                                'Näitä tarvitaan tekstien palauttamiseen ennalleen
Private VaihdettujenKahvat() As Long                                'ohjelman sammuessa. Ei kommentteja muuttujanimien
Private VaihdettujenTekstit() As String                             'pituudesta, kiitos!

Sub Main()

    Dim Sij As POINTAPI
    Dim Kahva As Long
    Dim Teksti As String
    Dim TxtPituus As Long

    App.TaskVisible = False                                         'Piilotetaan ohjelma
    If App.PrevInstance Then End                                    'Lopetetaan jos on jo käynnissä

    tmpvar = GetAsyncKeyState(vbKeyEscape)                          'Jottei ohjelma reagoi vanhoihin painalluksiin

    Do

        tmpvar = GetCursorPos(Sij)                                  'Haetaan kursorin sijainti
        Kahva = WindowFromPoint(Sij.x, Sij.y)                       'Haetaan kontrollin kahva

        TxtPituus = SendMessage(Kahva, WM_GETTEXTLENGTH, 0, 0)      'Haetaan tekstin pituus
        Teksti = String(TxtPituus, 0)

        SendMessageString Kahva, WM_GETTEXT, TxtPituus + 1, Teksti  'Haetaan kontrollin teksti

        Vaihda Kahva, Teksti, "OK", "Ookoo!"                        'Vaihdellaan tekstejä
        Vaihda Kahva, Teksti, "Käynnistä", "PANIC!"


        aika = Timer                                                'Vähän viivettä
        Do
            DoEvents
        Loop Until Timer > aika + 0.1

    Loop Until GetAsyncKeyState(vbKeyEscape)                        'Poistutaan luupista kun painetaan ESC

    For i = 1 To VaihdettujenMäärä                                  'Palautetaan kontrollien tekstit ennalleen
        tmpvar = SendMessageString(VaihdettujenKahvat(i), WM_SETTEXT, 0, VaihdettujenTekstit(i))
    Next i

End Sub

'Tämä hoitaa tekstien vaihtamisen
Private Sub Vaihda(hWnd As Long, ATxt As String, VTxt As String, KTxt As String)

    If ATxt = VTxt Then                                             'Onko sama teksti
        tmpvar = SendMessageString(hWnd, WM_SETTEXT, 0, KTxt)       'Korvataan teksti
        VaihdettujenMäärä = VaihdettujenMäärä + 1                   'Lisätään laskurin arvoa yhdellä
        ReDim Preserve VaihdettujenKahvat(1 To VaihdettujenMäärä)   'Kasvatetaan taulukkojen
        ReDim Preserve VaihdettujenTekstit(1 To VaihdettujenMäärä)  'kokoa tarpeen mukaan
        VaihdettujenKahvat(VaihdettujenMäärä) = hWnd                'Laitetaan kontrollien kahvat
        VaihdettujenTekstit(VaihdettujenMäärä) = VTxt               'ja vanhat tekstit muistiin
    End If

End Sub