Tipps und Tricks zu Visual Basic 6.0

Inhalt einer Textbox speichern und laden
Alle Formen beim Beenden entladen
"Ordner suchen" - Dialog aufrufen
Alle Dateien im Ordner mit allen Unterordnern ermitteln
Standartmailprogramm starten
Listbox steigend füllen
einfaches TCP/IP-Beispiel zum Verbinden von 2 PCs
Info's an eine laufende Anwendung beim Programmstart senden
runde Form erzeugen
Anzahl von Zeichen oder Silben im Text bestimmen
Größe von Dateien auch über 2 und 4 GB korrekt bestimmen
 
den kompletten Inhalt einer Textbox speichern und wieder laden  Download
Private Sub Command1_Click() 'Text laden
    Dim Datei As String
    Dim NR As Integer
    
    Datei = App.Path
    If Right$(Datei, 1) <> "\" Then
        Datei = Datei & "\"
    End If
    Datei = Datei & "Test.txt"
    
    NR = FreeFile
    Open Datei For Input As #NR
        Text1.Text = Input(LOF(NR), #NR)
    Close #NR
End Sub

Private Sub Command2_Click() 'Text speichern
    Dim Datei As String
    Dim NR As Integer
    
    Datei = App.Path
    If Right$(Datei, 1) <> "\" Then
        Datei = Datei & "\"
    End If
    Datei = Datei & "Test.txt"
    
    NR = FreeFile
    Open Datei For Output As #NR
        Print #NR, Text1.Text
    Close #NR
End Sub
 
alle Formen beim Beenden des Programmes entladen  Download
Private Sub Form_Unload(Cancel As Integer)
    Dim f As Form
    For Each f In Forms
        Unload f
        Set f = Nothing
    Next
End Sub
 
den Ordner suchen Dialog aufrufen und gewählten Pfad ermitteln  Download
Option Explicit

Private Type BrowseInfo
     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type

Private Const RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
    (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias _
    "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 _
    As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
    (ByVal pidList As Long, ByVal lpBuffer As String) As Long


Private Sub Command1_Click()
    Dim Pfad As String
    Pfad = OpenDialog(hWnd, "Ordner suchen")
    If Pfad = "" Then
        Exit Sub
    Else
        Drive1.Drive = Left$(Pfad, 3)
        Dir1.Path = Pfad
        File1.Path = Pfad
    End If
End Sub


Private Function OpenDialog(hwndOwner As Long, _
                sPrompt As String) As String
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim Result As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = RETURNONLYFSDIRS
     End With

     lpIDList = SHBrowseForFolder(udtBI)
     
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        Result = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If

     OpenDialog = sPath

End Function
 
alle Dateien im Verzeichnis, incl. der Unterverzeichnisse ermitteln  Download
Option Explicit

Private Declare Function FindFirstFile Lib "kernel32" _
    Alias "FindFirstFileA" (ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
    Alias "FindNextFileA" (ByVal hFindFile As Long, _
    lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" _
    Alias "GetFileAttributesA" (ByVal lpFileName _
    As String) As Long
Private Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long

Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, _
            Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Function FindFilesAPI(Path As String, SearchStr As String, _
                    FileCount As Integer, DirCount As Integer)
    Dim DateiName As String
    Dim DirName As String
    Dim dirNames() As String
    Dim nDir As Integer
    Dim i As Integer
    Dim hSearch As Long
    Dim WFD As WIN32_FIND_DATA
    Dim Count As Integer
    
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    
    nDir = 0
    ReDim dirNames(nDir)
    hSearch = FindFirstFile(Path & SearchStr, WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        Do
        DirName = StripNulls(WFD.cFileName)
        If (DirName <> ".") And (DirName <> "..") Then
            If GetFileAttributes(Path & DirName) And _
                        FILE_ATTRIBUTE_DIRECTORY Then
                dirNames(nDir) = DirName
                DirCount = DirCount + 1
                nDir = nDir + 1
                ReDim Preserve dirNames(nDir)
            Else
                FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh _
                        * MAXDWORD) + WFD.nFileSizeLow
                FileCount = FileCount + 1
                List1.AddItem Path & DirName
            End If
        End If
        Count = FindNextFile(hSearch, WFD)
        Loop Until Count = 0
        Count = FindClose(hSearch)
    End If
    
    
    If nDir > 0 Then
        For i = 0 To nDir - 1
            FindFilesAPI = FindFilesAPI + FindFilesAPI(Path _
            & dirNames(i) & "\", SearchStr, FileCount, DirCount)
        Next i
    End If
End Function


Sub Command1_Click()
    Dim SearchPath As String, FindStr As String
    Dim FileSize As Long
    Dim NumFiles As Integer, NumDirs As Integer
    
    List1.Clear
    SearchPath = Dir1.Path
    FindStr = Text2.Text
    FileSize = FindFilesAPI(SearchPath, FindStr, NumFiles, NumDirs)
    Text3.Text = NumFiles & " Dateien in " & NumDirs + 1 & " Ordner"
    Text4.Text = "DateiGröße = " & Format(FileSize, _
                        "#,###,###,##0") & " Bytes"
                    
    MsgBox "Fertig"
End Sub
 
Standartmailprogramm starten  Download
Private Declare Function ShellExecuteMail Lib "Shell32.dll" Alias _
        "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation _
        As String, ByVal lpFile As String, ByVal lpParameters _
        As String, ByVal lpDirectory As String, ByVal nShowCmd _
        As Long) As Long


Private Sub Command1_Click()
    Dim Result&, Buff$
    Buff = "mailto:" & "webmaster@henryf.de"
    Buff = Buff & "?Subject=" & "Dein Betreff"
    Buff = Buff & "&Body=" & "irgendein Text"
    Result = ShellExecuteMail(0&, "Open", Buff, "", "", 1)
End Sub
 
Listbox steigend füllen Download
If List1.ListCount = 0 Then
    List1.AddItem List1.ListCount
Else
    List1.AddItem List1.ListCount, Before = 1
End If
 
einfaches TCP/IP-Beispiel zum Verbinden von 2 PCs Download
hier ein kleines Beispiel wie man 2 Rechner im LAN oder per Internet mit Hilfe des TCP/IP-Protokolls verbindet. 
                                                Download hier >>Download
 
Info's an eine laufende Anwendung beim Programmstart senden Download
hier ein kleines Beispiel wie man beim Start einer Anwendung prüft ob diese bereits gestartet wurde und der bereits laufenden Anwendung Informationen übergibt. 
                                                Download hier >>Download
 
runde Form erzeugen Download
Private Declare Function SetWindowRgn Lib "user32" _
    (ByVal hWnd As Long, ByVal hRgn As Long, _
    ByVal bRedraw As Boolean) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" _
    (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
    ByVal Y2 As Long) As Long

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Dim Result As Long
    Result = SetWindowRgn(Form1.hWnd, _
        CreateEllipticRgn(0, 0, 200, 200), True)
End Sub
 
Anzahl von Zeichen oder Silben im Text bestimmen Download
Option Explicit
Option Compare Text 'wenn zwischen Groß- und Kleinschreibung _
                unterschieden werden soll, dann diese Zeile _
                entfernen

Private Sub Command1_Click()
    MsgBox AnzahlZeichen(Text1.Text, "e")
    MsgBox AnzahlZeichen(Text1.Text, "te")
End Sub

Private Function AnzahlZeichen(Text As String, _
                ZuSuchen As String) As Integer
    Dim Ersetzen As String
    On Error GoTo fehler
    If Len(ZuSuchen) = 0 Then
        AnzahlZeichen = -1
        Exit Function
    ElseIf Len(ZuSuchen) = 1 Then
        Ersetzen = ""
    ElseIf Len(ZuSuchen) > 1 Then
        Ersetzen = Space(Len(ZuSuchen) - 1)
    End If
    AnzahlZeichen = Len(Text) - _
        Len(Replace(Text, ZuSuchen, Ersetzen))
    Exit Function
    
fehler:
    AnzahlZeichen = -1
End Function  

 
Größe von Dateien auch über 2 und 4 GB korrekt bestimmen Download

Option Explicit

'es wird benötigt eine Drivebox:Drive1
'eine Dirbox:Dir1
'eine Filebox:File1
'ein Label:Label1

Private Declare Function FindFirstFile Lib "kernel32" _
    Alias "FindFirstFileA" (ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long

Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_Click()
    Dim Datei As String
    Datei = File1.Path
    If Right$(Datei, 1) <> "\" Then
        Datei = Datei & "\"
    End If
    Datei = Datei & File1.FileName
    Label1.Caption = GetFileSize(Datei) & " byte"
End Sub

Private Function GetFileSize(nFile As String) As Double
    Dim hSearch As Long
    Dim wFD As WIN32_FIND_DATA
    hSearch = FindFirstFile(nFile, wFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        GetFileSize = GetLargeSize(wFD.nFileSizeHigh, wFD.nFileSizeLow)
        Call FindClose(hSearch)
    End If
End Function

Private Function GetLargeSize(lHi As Long, lLo As Long) As Double
    Dim lMask As Long
    Dim vResult As Variant
    Dim vMult As Variant
    Dim vHibitValue As Variant
    ' Multiplikator zum Bitschieben
    vMult = CDec(2 ^ 32)
    ' Bitmaske zum Ausblenden des HiBit
    lMask = &H7FFFFFFF
    ' Summand fuer das ausgeblendete Bit, das
    'spaeter wieder addiert werden muss
    vHibitValue = CDec(2 ^ 31)
    If lHi < 0 Then
        vResult = (CDec((lHi And lMask)) + vHibitValue) * vMult
    Else
        vResult = CDec(lHi) * vMult
    End If
    If lLo < 0 Then
        vResult = vResult + CDec((lLo And lMask)) + vHibitValue
    Else
        vResult = vResult + CDec(lLo)
    End If
    GetLargeSize = vResult
End Function

 
 
Home