Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/inites/testini.bas

BASIC Source File | 1995-10-23 | 20.5 KB | 197 lines

    Option Explicit
'*************************************************************************'
'*                                                                       *'
'*        Program Name: TESTINI                                          *'
'*                                                                       *'
'*             Created: Sept 94             By: Christophe Tricaud       *'
'*                                              Compuserve N░ 100412,2653*'
'*                                              Paris, France.           *'
'*            Modified:              By:                                 *'
'*                                                                       *'
'*            Comments: This small program shows easy use of INI function*'
'*                      for those who do not want to use API. Just use   *'
'*                      the few functions of this program which are      *'
'*                      sufficient.                                      *'
'*                                                                       *'
'*************************************************************************'

'                                                                                                                                                                                                                                                                       '
'                                                                                                                                                                                                                                                                        '
'Global Constants declaration                                                                                                                                                                                                                                             '
'                                                                                                                                                                                                                                                                          '
'                                                                                                                                                                                                                                                                           '
    Global Const WM_WININICHANGE = &H1A
    Global Const nSize = 128
    Global Const HWND_BROADCAST = &HFFFF
    Global Const SPI_SETDESKPATTERN = 21
    Global Const SPI_SETBORDER = 6
    Global Const SPI_SETBEEP = 2
    Global Const SPI_SETDESKWALLPAPER = 20
    Global Const SPI_SETDOUBLECLICKTIME = 32
    Global Const SPI_SETSCREENSAVEACTIVE = 17
    Global Const SPI_SETSCREENSAVETIMEOUT = 15
    Global Const SPIF_SENDWININICHANGE = 2
    Global Const SPIF_UPDATEINIFILE = 1
'                                                                                                                                                                                                                                                   '
'                                                                                                                                                                                                                                                    '
'Type declarations                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                      '
'                                                                                                                                                                                                                                                       '
    Type RECT
      Left As Integer
      Top As Integer
      right As Integer
      Bottom As Integer
    End Type
'                                                                                                                                                                                                                                                                                                   '
'                                                                                                                                                                                                                                                                                                    '
'API declaration                                                                                                                                                                                                                                                                                      '
'                                                                                                                                                                                                                                                                                                      '
'                                                                                                                                                                                                                                                                                                       '
    Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFileName$)
    Declare Function WritePrivateProfileString% Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName$)
    Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
    Declare Function SystemParametersInfo Lib "User" (ByVal uAction As Integer, ByVal uParam As Integer, ByVal lpvParam As String, ByVal fuWinIni As Integer) As Integer
    Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Long
    Declare Function PostMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Long
    Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
    Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
    Declare Function FillRect Lib "User" (ByVal hDC As Integer, lpRect As RECT, ByVal hBrush As Integer) As Integer
'                                                                                                                                                                                                                                                   '
'                                                                                                                                                                                                                                                    '
'Variables declarations                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                      '
'                                                                                                                                                                                                                                                       '
    Global Windir As String         'Contient le rΘpertoire de Windows'

Function DelEntry (ByVal NomApplication As String, ByVal NomSection As String, ByVal NomEntree As String) As Integer
'                                                                                                                                                                                           '
'                                                                                                                                                                                            '
'ProcΘdure permet de supprimer une entrΘe                                                                                                                                                     '
'                                                                                                                                                                                              '
'                                                                                                                                                                                               '
    Dim A As Integer               'Longueur de retour                                                                                                                                                           '

    A = WritePrivateProfileString(NomSection, NomEntree, 0&, NomApplication)
    DelEntry = A

End Function

Function DelSection (ByVal NomApplication As String, ByVal NomSection As String) As Integer
'                                                                                                                                                                                           '
'                                                                                                                                                                                            '
'ProcΘdure permet de supprimer une entrΘe                                                                                                                                                     '
'                                                                                                                                                                                              '
'                                                                                                                                                                                               '
    Dim A As Integer               'Longueur de retour                                                                                                                                                           '

    A = WritePrivateProfileString(NomSection, 0&, "", NomApplication)
    DelSection = A

End Function

Sub FondEcran (F As Form, Titre As String)
'                                                                                                                                                   '
'                                                                                                                                                    '
'Permet de dessiner un fond dΘgradΘ bleu                                                                                                              '
'                                                                                                                                                      '
'                                                                                                                                                       '
    Dim I As Integer             'Boucle de lecture                       '
    Dim Res As Integer           'Resultat                                '
    Dim hBrush As Integer        'Handle du brush                         '
    Dim Trace As RECT            'Structre du cadre α remplir             '
    Dim HauteurTrace As Single   'Hauteur du rectangle                    '
    Dim OldMode As Integer       '                                        '
    'Calcul de la hauteur totale du rectangle                                                                                                                                                               '
    HauteurTrace = F.ScaleHeight / (127)
    OldMode = F.ScaleMode
    F.ScaleMode = 3
    F.Cls

    Trace.Left = 0
    Trace.Top = 0
    Trace.right = F.ScaleWidth
    Trace.Bottom = HauteurTrace
    'Dessin des rectangles avec brush                                                                                                                                       '
     For I = 0 To 255 Step 2
     hBrush = CreateSolidBrush(RGB(0, 0, 255 - I))
     Res = FillRect(F.hDC, Trace, hBrush)
     Res = DeleteObject(hBrush)
     Trace.Top = Trace.Bottom
     Trace.Bottom = HauteurTrace * (1 + (I / 2))
     Next
     'Dessin du titre                                                                                                                                       '
     F.FontSize = 32
     F.ForeColor = RGB(0, 0, 0)
     F.CurrentX = F.ScaleWidth - F.TextWidth(Titre) - 20
     F.CurrentY = .2 * F.TextHeight(Titre)
     F.Print Titre;
     F.CurrentX = F.ScaleWidth - F.TextWidth(Titre) - 25
     F.CurrentY = F.CurrentY - 5
     F.ForeColor = RGB(255, 255, 255)
     F.Print Titre
     'On remet le mode ancien                                                                                                                                       '
     F.ScaleMode = OldMode
End Sub

Sub GetEntries (NomApplication As String, NomSection As String, Tableau() As String)
'                                                                                                                                                                                                                                                                           '
'                                                                                                                                                                                                                                                                            '
'Cette procΘdure permet de rΘcupΘrer les entrΘe d'une section                                                                                                                                                                                                                 '
'                                                                                                                                                                                                                                                                              '
'                                                                                                                                                                                                                                                                               '
    Dim Retour As String
    Dim A As Integer
    Dim I As Integer
    Dim INull As String

    Retour = Space$(10000)
    INull = Chr$(0)

    A = GetPrivateProfileString(NomSection, 0&, "", Retour, 10000, NomApplication)
    '                                                                                                                                                                                                                                           '
    '                                                                                                                                                                                                                                            '
    'Transformation de retour en tableau                                                                                                                                                                                                          '
    '                                                                                                                                                                                                                                              '
    '                                                                                                                                                                                                                                               '
    Retour = Left$(Retour, A)
    While Len(Retour) <> 0
    I = I + 1
    ReDim Preserve Tableau(I)
    Tableau(I) = Left$(Retour, InStr(Retour, Chr$(0)) - 1)
    Retour = Right$(Retour, Len(Retour) - InStr(Retour, Chr$(0)))
    Wend
End Sub

Function GetIni (NomApplication As String, NomSection As String, NomEntree As String, NomDefaut As String, Taille As Integer) As String
'                                                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                                '
'Cette procΘdure permet d'effectuer une lecture d'un fichier INI                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                   '
    Dim Retour As String           'Valeur de retour                                                                                                                                                            '
    Dim A As Integer               'Longueur de retour                                                                                                                                                           '

    Retour = Space$(Taille)
    A = GetPrivateProfileString(NomSection, NomEntree, NomDefaut, Retour, Taille, NomApplication)

    If A <> 0 Then
    GetIni = Left$(Retour, A)
    Else
    GetIni = ""
    End If
End Function

Function WriteIni (NomApplication As String, NomSection As String, NomEntree As String, Valeur As String) As Integer
'                                                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                                '
'Cette procΘdure permet d'effectuer une Θcriture sur un fichier INI                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                   '
    Dim A As Integer               'Longueur de retour                                                                                                                                                           '

    A = WritePrivateProfileString(NomSection, NomEntree, Valeur, NomApplication)
    WriteIni = A
End Function