Tips&Tricks

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



 ' Функция за четене на стойност от INI файл

Public Function Fun_ReadINIValue(strSection As String, _

                                 strKey As String, _

                                 strINIFileName, _

                                 Optional strDefaultCaption As String = "") As String



Dim strRet As String

Dim lngSize As Long

Dim lngResult As Long



 ' Ако смятате че реда който ще прочитате е по-дълъг от 1024 символа, сменете цифрата в следващия ред

Const lngLongestValue As Long=1024



strRet = String(lngLongestValue, 0)

lngResult = GetPrivateProfileString(strSection, strKey, strDefaultCaption, strRet, lngLongestValue, strINIFileName)

strRet = Left$(strRet, lngResult)



Fun_GetCaption = Fun_ReadINIValue



End Function



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



 ' Процедура за запис на стойност в INI файл

Public Sub Sub_WriteINIValue(strSection As String, _

                             strKey As String, _

                             strValue As String, _

                             strINIFile As String)





WritePrivateProfileString strSection, strKey, strValue & Chr$(0), strINIFile



End Sub



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



 ' Функция за четене на съдържанието на текстов файл

 ' Удобна е за не много големи файлове (например до 4000-5000 реда или 100-200 килобайта)

Public Function Fun_GetTextFileContents(strFileName As String) As String



Dim strLine As String

Dim strFileContents As String

Dim intFreeFile As Integer

Dim lngLOF As Long



intFreeFile = FreeFile()

Open strFileName For Input As #intFreeFile

     lngLOF = LOF(intFreeFile)

     If lngLOF > 0 Then

        Do While Not EOF(intFreeFile)

           Line Input #intFreeFile, strLine

           strFileContents = strFileContents & strLine & vbCrLf

        Loop

     End If

Close #intFreeFile



Fun_GetTextFileContents = strFileContents



End Function



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



 ' Функция за четене от двоичен файл

 ' Ако за intFileNumber се изпрати 0, файла указан в strFileToOpen ще се

 ' отвори, ще се прочете и ще се затвори

 ' Ако за intFileNumber се изпрати >0, това значи че файл с такъв номер вече е

 ' отворен от друго място в програмата. Той трябва да е отворен "For Binary"

 ' Функцията връща броя на прочетените байтове а в параметъра byteData() е

 ' прочетеното съдържание

 ' Ако няма достатъчно данни (например ако са заявени да се прочетат

 ' например 1000 байта от отместване 500 а файла е с размер само 1300

 ' байта), функцията връща 0

Public Function Fun_ReadFileData(intFileNumber As Integer, _

                                 lngStart As Long, _

                                 lngLength As Long, _

                                 byteData() As Byte, _

                                 Optional strFileToOpen As String) As Long



Dim lngFileLen As Long

Dim strTemp As String

Dim intI As Integer

Dim boolInternalFileOpen As Boolean



If intFileNumber = 0 Then

   intFileNumber = FreeFile()

   Open strFileToOpen For Binary Access As #intFileNumber

   boolInternalFileOpen = True

End If



lngFileLen = LOF(intFileNumber)



 ' Да се прочете от файла само ако съществуват lngLength байта данни от отместване lngStart

If (lngFileLen >= lngStart And lngFileLen >= (lngStart + lngLength - 1) And lngStart > 0 And lngLength > 0) Then

   ReDim byteData(lngLength - 1) As Byte

   Get #intFileNumber, lngStart, byteData

   If boolDecryptData = True Then

      Call Sub_DecryptByteArray(byteData, pbytePass, boolUseDateTimeDecryption)

   End If

   Fun_ReadFileData = UBound(byteData) + 1

End If



If boolInternalFileOpen = True Then

   Close #intFileNumber

End If





End Function



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



 ' Процедура за запис в двоичен файл

 ' Ако за intFileNumber се изпрати 0, файла ще се отвори, ще се прочете и ще се затвори

 ' Ако за intFileNumber се изпрати >0, това значи че файл с такъв номер вече е

 ' отворен от друго място в програмата. Той трябва да е отворен "For Binary"

 ' В lngStart се задава отместването спрямо началото на файла от където да се запише byteData

Public Sub Sub_WriteFileData(intFileNumber As Integer, _

                             lngStart As Long, _

                             byteData() As Byte, _

                             Optional strFileName As String="")



Dim boolInternalFileOpen As Boolean



If intFileNumber = 0 Then

   intFileNumber = FreeFile()

   Open strFileName For Binary Access As #intFileNumber

   boolInternalFileOpen = True

End If



Put #intFileNumber, lngStart, byteData



If boolInternalFileOpen = True Then

   Close #intFileNumber

End If



End Sub

 ' Процедурата установява шрифта за всички обекти (контроли) върху Форма

 ' Може лесно да бъдат добавени и други свойства на шрифта

 ' Ако boolSetToAllForms = True ще се промени шрифта на всички обекти (контроли) върху всички Форми в проекта

 ' (правете това само ако всички форми от проекта са заредени)

 ' Ако някой от контролите има .Tag "FontLocked" неговия шрифт няма да се промени

 ' Пример: Call Sub_SetFont(Form1,"Tahoma",204,False) -> Ще промени шрифта на всички обекти (контроли) върху Form1

Public Sub Sub_SetFont( _

           objTarget As Object, _

           strFontName As String, _

           intFontCharset As Integer, _

           Optional boolSetToAllForms As Boolean = False)





On Error Resume Next



Dim objTargets As Object

Dim objTargetControls As Object





 ' Ако не е за всички Форми а само за objTarget

If boolSetToAllForms = False Then

   For Each objTargetControls In objTarget.Controls

       If objTargetControls.Tag <> "FontLocked" Then

          objTargetControls.Font.Charset = intFontCharset

          objTargetControls.Font.Name = strFontName

       End If

   Next

Else ' Ако е за всички Форми в проекта

   For Each objTargets In VB.Forms

       For Each objTargetControls In objTargets.Controls

           If objTargetControls.Tag <> "FontLocked" Then

              objTargetControls.Font.Charset = intFontCharset

              objTargetControls.Font.Name = strFontName

           End If

       Next

   Next

End If



End Sub

Option Explicit



Private Declare Function SendMessage _

Lib "user32" Alias "SendMessageA" ( _

ByVal hwnd As Long, ByVal wMsg As Long, _

ByVal wParam As Long, ByVal lParam As Long) As Long



Private Const LB_ITEMFROMPOINT = 425

Private Sub Form_Load()

Dim i As Long



For i = 0 To 10

    List1.AddItem i

Next i



End Sub



Private Sub List1_MouseMove( _

Button As Integer, Shift As Integer, X As Single, Y As Single)

  Dim X_ As Integer, Y_ As Integer

  Dim Coord As Long

  Dim RetVal As Long



  X_ = X \ Screen.TwipsPerPixelX

  Y_ = Y \ Screen.TwipsPerPixelY



  Coord = MakeDWord(X_, Y_)



  RetVal = SendMessage( _

  List1.hwnd, LB_ITEMFROMPOINT, 0&, Coord)



  If HiWord(RetVal) = 1 Then

    'Курсора е извън list box-a -> outside the client area

  End If



  If HiWord(RetVal) = 0 Then

    Me.Caption = List1.List(LoWord(RetVal))

  End If



End Sub



Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long

   MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)

End Function



Function LoWord(DWord As Long) As Integer

      If DWord And &H8000& Then ' &H8000& = &H00008000

         LoWord = DWord Or &HFFFF0000

      Else

         LoWord = DWord And &HFFFF&

      End If

End Function



Function HiWord(DWord As Long) As Integer

  HiWord = (DWord And &HFFFF0000) \ &H10000

End Function