Visual Basic Forum

Visual Basic Forum
für VB6 und VB.NET Programmierer
  		RegistrierenRegistrieren  LoginLogin

Neues Thema eröffnen   Neue Antwort erstellen    Visual Basic Forum Foren-Übersicht -> [VB6] Source Codes
Autor
Nachricht
ZiG_
Überflieger
Überflieger

Anmeldedatum: 07.03.2007
Beiträge: 1248
Snippets Sammlung
Verfasst am: 08.12.2007, 20:06
Ich poste euch mal paar Snippets die recht nützlich sind. Jedenfalls die, die mir gerade einfallen.

Evt. postet ihr auch welche, so dass ne kleine Sammlung zusammen kommt.


WaitHere - Programm läuft bestimmte Zeit in einer Schleife. Eine Art Pause.
Code:

Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Function WaitHere(ByVal Seconds As Long)
Dim x1 As Long, x2 As Long
x2 = GetTickCount + (Seconds * 1000)
Do Until x1 >= x2
 x1 = GetTickCount
 DoEvents
Loop
End Function



FileExist - Überprüft ob eine Datei existiert oder nicht
Code:
Public Function FileExists(ByVal FileName As String) As Boolean
On Local Error Resume Next
FileExists = (Dir$(FileName) <> "")
End Function



GetFilename - Liest aus einem Pfad den Dateinamen aus
Code:
Public Function GetFilename(ByVal Filepath As String) As String
GetFilename = Mid$(Filepath, InStrRev(Filepath, "\") + 1)
End Function



GetFilepath - Gibt den Pfad ohne Dateinamen zurück
Code:
Public Function GetFilepath(ByVal Filepath As String) As String
GetFilepath = Mid$(Filepath, 1, InStrRev(Filepath, "\"))
End Function



GetFileExtension - Liest die Dateiendung aus
Code:
Public Function GetFileExtension(ByVal Filepath As String) As String
GetFileExtension = Mid$(Filepath, InStrRev(Filepath, "."))
End Function



CheckHash - Überprüft MD5 und SHA Hashes ob sie auch nur aus Hexadezimalen Zeichen bestehen.
Code:
Public Function check_hash(ByVal Hash As String) As Boolean
Dim i As Integer, x As Long, bol As Boolean
If Len(Hash) = 32 Or Len(Hash) = 40 Then
 For i = 1 To Len(Hash)
   x = Asc(Mid$(Hash, i, 1))
   Select Case (x)
    Case 48 To 57
     bol = True
    Case 97 To 102
     bol = True
    Case Else
     bol = False
     Exit For
   End Select
 Next i
Else
 bol = False
End If
check_hash = bol
End Function


SaveRes - Zum speichern und registrieren von ActiveX Datein.
Code:
Public Function SaveRes(ID As Integer, Filepath As String)
Dim xBuffer() As Byte
xBuffer = LoadResData(ID, "CUSTOM")
Dim ff As Integer
ff = FreeFile
Open Filepath For Binary As #ff
Put #ff, , xBuffer
Close

DoEvents
Call Shell("regsvr32.exe " & Filepath & " -s")

End Function

Verwendung:
Code:

If Not FileExists(Winpath & "\system32\CoolXPPicture.ocx") Then
 Call SaveRes(101, Winpath & "\system32\CoolXPPicture.ocx")
End If


NewDoEvents - Führt nur bei jedem 10ten mal DoEvents wirklich aus.
Hat nen Geschwindigkeitsvorteil bei Schleifen wo es einfach schneller gehen soll. Statt 10 könnt ihr auch ne andere Zahl wählen.
Code:
Public Function NewDoEvents()
Static xCount As Integer
If xCount = 10 Then
 DoEvents
 xCount = 0
Else
 xCount = xCount + 1
End If
End Function

Es gibt auch ne Funktion die überprüft ob irgendwelche Events ausgeführt werden müßten bzw. ob DoEvents gebraucht wird.
Mir genügt aber die oben angeführte.


CommonDlg - Einfache Funktion um das CommonDialog Control nutzen zu können ohne immer wieder den selben Code zu schreiben.
Code:
Public Function CommonDlg(ByVal nFilename As String, ByVal nDialogTitle As String, ByVal nInitDir As String, ByVal nFilter As String, ByVal OpenOrSave As Integer) As String
On Local Error GoTo Err:

With cdlg
 .CancelError = True
 .InitDir = nInitDir
 .DialogTitle = nDialogTitle
 .FileName = nFilename
 .Filter = nFilter
 If OpenOrSave = 0 Then
  .ShowOpen
 ElseIf OpenOrSave = 1 Then
  .ShowSave
 End If
End With
 
CommonDlg = cdlg.FileName
 
Exit Function
Err:
cdlg.FileName = ""
CommonDlg = cdlg.FileName
End Function

Wenn ein leerer String zurückgegeben wird, dann wurde abgebrochen.

Na gut. Mehr fällt mir grad nicht ein.
Ist nicht perfekt, aber vielleicht ist was nützliches für euch dabei.

hf, ZiG
_________________
Wer nicht auf seine Weise denkt, denkt überhaupt nicht. (Oscar Wilde)

Zuletzt bearbeitet von ZiG_ am 21.12.2007, 18:44, insgesamt 2-mal bearbeitet
 
Lukas_
Tutorial Leser
Tutorial Leser

Anmeldedatum: 06.10.2007
Beiträge: 51

Verfasst am: 08.12.2007, 20:18
das ist vielleicht noch hilfreich:
XP-Style
Code:

Private Declare Sub ExitProcess Lib "kernel32.dll" (ByVal uExitCode As Long)
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long

Private Function AppPath(ByVal zPath As String) As String
  If Right$(zPath, 1) = "\" Then AppPath = zPath Else AppPath = zPath & "\"
End Function

Private Function FileExist(ByVal strPath As String) As Boolean
  On Local Error GoTo ErrFile
  Open strPath For Input Access Read As #1
  Close #1
  FileExist = True
  Exit Function
ErrFile:
  FileExist = False
End Function

Private Sub MakeManifest()
  Dim file$, file2$, qwe As String
  file$ = AppPath(App.Path) & App.EXEName & ".exe.MANIFEST"
  If Not FileExist(file$) Then
    qwe = "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf _
        & "<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">" & vbCrLf _
        & "<assemblyIdentity type=""win32"" processorArchitecture=""*"" version=""6.0.0.0"" name=""name""/>" & vbCrLf _
        & "<description>Enter your Description Here</description>" & vbCrLf _
        & "<dependency>" & vbCrLf _
        & "   <dependentAssembly>" & vbCrLf _
        & "      <assemblyIdentity" & vbCrLf _
        & "           type=""win32""" & vbCrLf _
        & "           name=""Microsoft.Windows.Common-Controls"" version=""6.0.0.0""" & vbCrLf _
        & "           language=""*""" & vbCrLf _
        & "           processorArchitecture=""*""" & vbCrLf _
        & "         publicKeyToken=""6595b64144ccf1df""" & vbCrLf _
        & "      />" & vbCrLf _
        & "   </dependentAssembly>" & vbCrLf _
        & "</dependency>" & vbCrLf _
        & "</assembly>" & vbCrLf
    Open file$ For Binary Access Write Lock Write As #1 Len = 1
    Put #1, , qwe
    Close #1
    SetAttr file$, vbReadOnly Or vbHidden ' Or vbSystem
    file2$ = AppPath(App.Path) & App.EXEName & ".exe"
    Shell file2$, vbNormalFocus
    ExitProcess 1
  End If
End Sub

Public Sub InitControlsXP()
  MakeManifest
  InitCommonControls
End Sub


'Form:
Private Sub Form_Initialize()
  InitControlsXP
End Sub

_________________
 
ZiG_
Überflieger
Überflieger

Anmeldedatum: 07.03.2007
Beiträge: 1248

Verfasst am: 08.12.2007, 20:38
Dazu sollte man evt. sagen, dass so ne manifest Probleme mit sich bringt.
Bzw. der XpStyle damit.

Labels in Frames werden nicht richtig dargestellt und so weiter.
Das meiste kann man lösen indem man das Label oder andere Objekte einfach in eine Picturebox gibt.
Die Picturebox dient also als Kontainer.

mfg
_________________
Wer nicht auf seine Weise denkt, denkt überhaupt nicht. (Oscar Wilde)
 
ZiG_
Überflieger
Überflieger

Anmeldedatum: 07.03.2007
Beiträge: 1248

Verfasst am: 21.12.2007, 18:34
Funktion zum ocx files erstellen und registrieren

Code:

Public Function SaveRes(ID As Integer, nFilepath As String)
if Not FileExists(nFilePath) then
 Dim nBuffer() As Byte
 nBuffer = LoadResData(ID, "CUSTOM")
 Dim ff As Integer
 ff = FreeFile
 Open nFilepath For Binary As #ff
 Put #ff, , nBuffer
 Close #ff
 DoEvents
 Call Shell("regsvr32.exe " & nFilepath & " -s")
End if
End Function


Der Funktion übergibt man die ID der Ressource und den Pfad zum erstellen. Dann wird überprüft ob die Datei schon existiert.
Wenn nicht, wird sie erstellt und im Hintergrund registriert.
Es wird noch die Funktion "FileExists" gebraucht.

Man könnte auch direkt in der Funktion den Windowspfad ermitteln lassen.
Ist eher für Faule, aber vom Code her eigentlich keine so gute Lösung, da für jede ocx der Pfad neu ermittelt wird.

Code:

Public Function SaveRes(ID As Integer, nFilename As String)
Dim nFilepath as string
nFilepath = Environ$("windir") & "\" & nFilename
if Not FileExists(nFilepath) then
 Dim nBuffer() As Byte
 nBuffer = LoadResData(ID, "CUSTOM")
 Dim ff As Integer
 ff = FreeFile
 Open nFilepath For Binary As #ff
 Put #ff, , nBuffer
 Close #ff
 DoEvents
 Call Shell("regsvr32.exe " & nFilepath & " -s")
End if
End Function


mfg, ZiG
_________________
Wer nicht auf seine Weise denkt, denkt überhaupt nicht. (Oscar Wilde)

Zuletzt bearbeitet von ZiG_ am 21.12.2007, 19:14, insgesamt einmal bearbeitet
 
ZiG_
Überflieger
Überflieger

Anmeldedatum: 07.03.2007
Beiträge: 1248

Verfasst am: 21.12.2007, 18:43

Ordner Dialog

Ich denke mal die meisten kennen das Common Dialog Steuerelement.
Wenn man aber einen Dialog braucht, indem man Ordner auswählen kann um z.B. den Speicherpfad mehrer Dateien anzugeben, dann kann man das Common Dialog nicht nehmen.

Den Code einfach in ein Modul einfügen.

Code:

Option Explicit

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 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 BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 256

Function DirDialog(Beschriftung As String) As String
Dim pidl As Long
Dim path As String
Dim bi As BrowseInfo

bi.hwndOwner = Screen.ActiveForm.hWnd
bi.lpszTitle = lstrcat(Beschriftung, "")
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl = SHBrowseForFolder(bi)

If pidl Then
 path = String(MAX_PATH, 0)
 SHGetPathFromIDList pidl, path
 CoTaskMemFree pidl
 path = Left(path, InStr(path, vbNullChar) - 1)
End If
DirDialog = path
End Function



Und so kann man den Dialog aufrufen:
Code:

Dim nDir As String

nDir = DirDialog("Festplatte C:\ z.B")
If Len(nDir) <> 0 Then
 'Euer code
End If


Man muß eine Festplatte angeben.
Am besten einfach von Windows.
Das könnt ihr schnell und einfach so ermitteln:
Code:

Dim nDrive as string, nWinpath as string

nWinpath = Environ$("windir")
nDrive = Mid$(nWinpath, 1, 3)


mfg
_________________
Wer nicht auf seine Weise denkt, denkt überhaupt nicht. (Oscar Wilde)
 
Neues Thema eröffnen   Neue Antwort erstellen    Visual Basic Forum Foren-Übersicht -> [VB6] Source Codes

Tags: getfilepath, newdoevents, fileexist, speichern, regsvr32, snippets

  
 Verwandte Themen   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Wie kann ich mich bei euch anmelden?? 796 20.05.2002, 00:28
Keine neuen Beiträge Eine kleine Frage an euch.. 906 30.09.2007, 08:57
Keine neuen Beiträge TopMost Funktion unter DirectX 921 27.07.2007, 10:48
Keine neuen Beiträge Wie Funktion nutzen ? 1098 29.06.2007, 20:59
Keine neuen Beiträge update funktion einbauen 1341 28.01.2007, 23:11
 




[ Time: 0.3105s ][ Queries: 97 (0.0924s) ][ GZIP on - Debug on ]