620 lines
23 KiB
QBasic
620 lines
23 KiB
QBasic
Attribute VB_Name = "WindowsAPI"
|
||
Option Explicit
|
||
|
||
'<Constant>---------------------------------------------
|
||
'---- no selection of a ListBox, or ComboBox
|
||
|
||
Public Const lbNoSelection As Integer = -1
|
||
|
||
'---- API constants
|
||
Public Const SW_SHOW As Long = 5
|
||
Public Const CB_ERR As Integer = (-1)
|
||
Public Const CB_FINDSTRING As Long = &H14C
|
||
Public Const WM_USER = &H400
|
||
Public Const CB_SHOWDROPDOWN = WM_USER + 15
|
||
Public Const CB_GETDROPPEDSTATE = (WM_USER + 23)
|
||
Global Const SWP_NOMOVE = 2
|
||
Global Const SWP_NOSIZE = 1
|
||
Global Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
|
||
Global Const HWND_TOPMOST = -1
|
||
Global Const HWND_NOTOPMOST = -2
|
||
|
||
'---- drawing
|
||
Public Const WM_SETREDRAW As Long = &HB
|
||
Public Const REDRAWOFF As Long = 0
|
||
Public Const REDRAWON As Long = 1
|
||
|
||
Public Const RDW_UPDATENOW = &H100
|
||
|
||
'---- network
|
||
Public Const DRIVE_CDROM As Long = 5
|
||
Public Const DRIVE_FIXED As Long = 3
|
||
Public Const DRIVE_RAMDISK As Long = 6
|
||
Public Const DRIVE_REMOTE As Long = 4
|
||
Public Const DRIVE_REMOVABLE As Long = 2
|
||
Public Const DRIVE_UNIDENTIFIED As Long = -1
|
||
|
||
Public Const ERROR_SUCCESS As Long = 0&
|
||
Public Const RESOURCETYPE_DISK As Long = &H1
|
||
|
||
Private Const NORMAL_PRIORITY_CLASS = &H20&
|
||
Private Const SYNCHRONIZE = &H100000
|
||
|
||
Enum TopStatus
|
||
AlwaysOnTop = True
|
||
Default = False
|
||
End Enum
|
||
|
||
|
||
|
||
'</Constant>--------------------------------------------
|
||
|
||
'<Type>-------------------------------------------------
|
||
Type RECT
|
||
rLeft As Long
|
||
rTop As Long
|
||
rRight As Long
|
||
rBottom As Long
|
||
End Type
|
||
|
||
Type PROCESSENTRY32
|
||
dwSize As Long
|
||
cntUsage As Long
|
||
th32ProcessID As Long
|
||
th32DefaultHeapID As Long
|
||
th32ModuleID As Long
|
||
cntThreads As Long
|
||
th32ParentProcessID As Long
|
||
pcPriClassBase As Long
|
||
dwFlags As Long
|
||
szexeFile As String * 260
|
||
End Type
|
||
|
||
Private Type STARTUPINFO
|
||
cb As Long
|
||
lpReserved As String
|
||
lpDesktop As String
|
||
lpTitle As String
|
||
dwX As Long
|
||
dwY As Long
|
||
dwXSize As Long
|
||
dwYSize As Long
|
||
dwXCountChars As Long
|
||
dwYCountChars As Long
|
||
dwFillAttribute As Long
|
||
dwFlags As Long
|
||
wShowWindow As Integer
|
||
cbReserved2 As Integer
|
||
lpReserved2 As Long
|
||
hStdInput As Long
|
||
hStdOutput As Long
|
||
hStdError As Long
|
||
End Type
|
||
|
||
Private Type PROCESS_INFORMATION
|
||
hProcess As Long
|
||
hThread As Long
|
||
dwProcessId As Long
|
||
dwThreadId As Long
|
||
End Type
|
||
|
||
'</Type>------------------------------------------------
|
||
|
||
'<Public>-----------------------------------------------
|
||
Public ReturnCode As Long
|
||
'</Public>----------------------------------------------
|
||
|
||
'<Declaration>------------------------------------------
|
||
'---- Win APIs
|
||
|
||
|
||
|
||
|
||
' zun<75>chst die ben<65>tigten API-Deklarationen
|
||
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
|
||
|
||
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
|
||
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
|
||
Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
|
||
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long
|
||
|
||
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
|
||
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As String) As Long
|
||
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
|
||
Public 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
|
||
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
|
||
Public Declare Function ShellExecute 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
|
||
Declare Function GetActiveWindow Lib "user32" () As Integer
|
||
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
|
||
Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex As Long)
|
||
Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
|
||
Declare Function GetLastError Lib "kernel32" () As Long
|
||
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
|
||
Private Declare Function OSGetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
|
||
Private Declare Function VerInstallFile Lib "version.dll" Alias "VerInstallFileA" (ByVal FLAGS&, ByVal SrcName$, ByVal DestName$, ByVal SrcDir$, ByVal DestDir$, ByVal CurrDir As Any, ByVal TmpName$, lpTmpFileLen&) As Long
|
||
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
|
||
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
|
||
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal sDrive As String) As Long
|
||
Public Declare Function WNetGetUser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpusername As String, lpnLength As Long) As Long
|
||
Public Declare Function GetTickCount Lib "kernel32" () As Long
|
||
|
||
Public Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
|
||
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
|
||
Public Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
|
||
Public Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
|
||
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
|
||
Public Declare Function GetForegroundWindow Lib "user32" () As Long
|
||
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
|
||
|
||
Public Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
|
||
Public Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As Long
|
||
|
||
|
||
Public Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
|
||
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
|
||
|
||
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal _
|
||
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
|
||
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
|
||
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
|
||
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
|
||
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
|
||
PROCESS_INFORMATION) As Long
|
||
|
||
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
|
||
Public Declare Function CreateToolhelpSnapshot Lib "kernel32.dll" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
|
||
Public Declare Function ProcessFirst Lib "kernel32.dll" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
|
||
Public Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
|
||
Public Declare Function TerminateProcess Lib "kernel32.dll" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
|
||
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
|
||
Public Declare Function ProcessNext Lib "kernel32.dll" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
|
||
|
||
Public Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
|
||
|
||
'</Declaration>-----------------------------------------
|
||
Private Declare Function GetModuleFileName Lib "kernel32" Alias _
|
||
"GetModuleFileNameA" (ByVal hModule As Long, _
|
||
ByVal lpFileName As String, ByVal nSize As Long) As Long
|
||
Private Const MAX_PATH = 260
|
||
|
||
|
||
|
||
Private Type SHELLEXECUTEINFO
|
||
cbSize As Long
|
||
fMask As Long
|
||
hwnd As Long
|
||
lpVerb As String
|
||
lpFile As String
|
||
lpParameters As String
|
||
lpDirectory As String
|
||
nSHow As Long
|
||
hInstApp As Long
|
||
lpIDList As Long
|
||
lpClass As String
|
||
hkeyClass As Long
|
||
dwHotKey As Long
|
||
hIcon As Long
|
||
hProcess As Long
|
||
End Type
|
||
|
||
|
||
' SHELLEXECUTEINFO fMask-Konstanten
|
||
Private Const SEE_MASK_CLASSKEY = &H3 ' Struktur wird mit dem Handle des Registry-
|
||
' Schl<68>ssels f<>r die Klasse gef<65>llt
|
||
Private Const SEE_MASK_CLASSNAME = &H1 ' Struktur wird mit dem Klassennamen oder GUID
|
||
' gef<65>llt der die Datei beschreibt
|
||
Private Const SEE_MASK_CONNECTNETDRV = &H80 ' Struktur verbindet den PC mit einem
|
||
' Netzlaufwerk falls n<>tig, lpFile muss der UNC-Pfadname im Netzwerk sein
|
||
Private Const SEE_MASK_DOENVSUBST = &H200 ' Struktur wird mit Umgebungsvariablen des
|
||
' Programms gef<65>llt, diese werden in lpDirectory oder lpFile gepackt
|
||
Private Const SEE_MASK_FLAG_DDEWAIT = &H100 ' die Funktion wartet, dass die DDE ihre
|
||
' Vorg<72>nge abgeschlossen hat und kehrt dann erst zur<75>ck
|
||
Private Const SEE_MASK_FLAG_NO_UI = &H400 ' die Funktion zeigt keine Fehler-Dialogboxen an
|
||
Private Const SEE_MASK_HOTKEY = &H20 ' dwHotkey wird gef<65>llt
|
||
Private Const SEE_MASK_ICON = &H10 ' hIcon wird mit dem Icon Handle des
|
||
' Standardicons der Anwendung gef<65>llt
|
||
Private Const SEE_MASK_IDLIST = &H4 ' benutzt die lpIDLIST-Option, um das Programm zu
|
||
' starten, das in ihr beschrieben ist
|
||
Private Const SEE_MASK_INVOKEIDLIST = &HC ' benutzt die lpIDLIST-Option, um das
|
||
' Programm zu starten, das in ihr beschrieben ist
|
||
Private Const SEE_MASK_NOCLOSEPROCESS = &H40 ' f<>llt die Struktur-Option hProcess
|
||
' mit dem Process-Handle der gestarteten Anwendung
|
||
|
||
' SHELLEXECUTEINFO nShow-Konstanten
|
||
Private Const SW_HIDE = 0 ' versteckt das Fenster
|
||
Private Const SW_MAXIMIZE = 3 ' maximiert das Fenster
|
||
Private Const SW_MINIMIZE = 6 ' minimiert das Fenster
|
||
Private Const SW_RESTORE = 9 ' stellt das Fenster wieder her
|
||
|
||
Private Const SW_SHOWMAXIMIZED = 3 ' zeigt das Fenster maximiert an
|
||
Private Const SW_SHOWMINIMIZED = 2 ' zeigt das Fenster minimiert an
|
||
Private Const SW_SHOWMINNOACTIVE = 7 ' zeigt das Fenster minimiert an aber aktiviert
|
||
' es nicht
|
||
Private Const SW_SHOWNA = 8 ' zeigt das Fenster an, aber aktiviert es nicht
|
||
Private Const SW_SHOWNOACTIVATE = 4 ' zeigt das Fenster in der besten Gr<47><72>e und
|
||
' Position an aber aktiviert es nicht
|
||
Private Const SW_SHOWNORMAL = 1 ' zeigt das Fenster ganz normal an
|
||
|
||
' SHELLEXECUTEINFO hInstApp R<>ckgabe-Konstanten
|
||
Public Const SE_ERR_ACCESSDENIED = 5 ' Zugriff verweigert
|
||
Private Const SE_ERR_ASSOCINCOMPLETE = 27 ' Dateityp ist nicht ausreichend assoziiert
|
||
Private Const SE_ERR_DDEBUSY = 30 ' DDE konnte nicht gestartet werden
|
||
Private Const SE_ERR_DDEFAIL = 29 ' DDE ist gescheitert
|
||
Private Const SE_ERR_DDETIMEOUT = 28 ' DDE-Zeitlimit wurde ereicht
|
||
Private Const SE_ERR_DLLNOTFOUND = 32 ' eine ben<65>tigte Dll wurde nicht gefunden
|
||
Private Const SE_ERR_FNF = 2 ' Datei wurde nicht gefunden
|
||
Private Const SE_ERR_NOASSOC = 31 ' Dateityp ist nicht assoziiert
|
||
Private Const SE_ERR_OOM = 8 ' nicht gen<65>gend Speicher verf<72>gbar
|
||
Private Const SE_ERR_PNF = 3 ' Pfad wurde nicht gefunden
|
||
Private Const SE_ERR_SHARE = 26 ' Datei konnte nicht ge<67>ffnet werden da sie bereits
|
||
' verwendet wird
|
||
|
||
' SHELLEXECUTEINFO dwHotKey-Konstanten
|
||
Private Const HOTKEYF_ALT = &H4 ' benutzt ALT f<>r den Hotkey
|
||
Private Const HOTKEYF_CONTROL = &H2 ' benutzt STRG f<>r den Hotkey
|
||
Private Const HOTKEYF_EXT = &H8 ' benutzt den Extendend-Key f<>r den Hotkey
|
||
Private Const HOTKEYF_SHIFT = &H1 ' benutzt Shift f<>r den Hotkey
|
||
|
||
' WaitForSingleObject dwMillisekond-Konstante
|
||
Private Const INFINITE = &HFFFF ' unendlich warten
|
||
|
||
' WaitForSingleObject R<>ckgabe-Konstanten
|
||
Private Const WAIT_ABANDONED = &H80 ' der Mutex der in hHanlde angegeben ist wird
|
||
' nicht freigegeben, so lange der Eltern-Thread zerst<73>rt ist. Der Mutex ist nun
|
||
' Bestandteil des aufrufenden Threads und ist nicht mehr im signalisierenden Status
|
||
Private Const WAIT_FAILED = &HFFFFFFFF ' die Funktion ist gescheitert
|
||
Private Const WAIT_OBJECT_0 = &H0 ' das Objekt, das in hHandle spezifiziert ist,
|
||
' ist in einem signalisierendem Status
|
||
Private Const WAIT_TIMEOUT = &H102 ' das Zeitlimit f<>r eine <20>nderung des
|
||
' Thread-Status ist abgelaufen
|
||
|
||
|
||
Const SWP_NOACTIVATE = &H10
|
||
Const SWP_SHOWWINDOW = &H40
|
||
|
||
'-----------------------------------------------------------
|
||
' <Purpose> finds a string in a ComboBox and highlights it
|
||
'-----------------------------------------------------------
|
||
Public Function ComboFindString(ByVal FindThis As String, ThisComboBox As ComboBox) As Integer
|
||
|
||
'---- preliminary error checking
|
||
If ((ThisComboBox.ListCount = 0) Or (FindThis = "")) Then
|
||
ComboFindString = lbNoSelection
|
||
Exit Function
|
||
End If
|
||
|
||
'---- null terminate the string and perform the find
|
||
FindThis = FindThis & Chr(0)
|
||
ReturnCode = SendMessage(ThisComboBox.hwnd, CB_FINDSTRING, -1, FindThis)
|
||
|
||
'---- process the return code
|
||
If (ReturnCode = CB_ERR) Then
|
||
ComboFindString = lbNoSelection
|
||
Else
|
||
ComboFindString = CInt(ReturnCode)
|
||
End If
|
||
|
||
End Function
|
||
|
||
|
||
Public Function CreateTheTempDxfFile(ByVal SrcFileName As String) As String
|
||
|
||
'VerInstallFile under Windows 95 does not handle
|
||
' long filenames, so we must give it the short versions
|
||
' (32-bit only).
|
||
Const VIFF_FORCEINSTALL = &H1
|
||
Dim strShortSrcName As String
|
||
Dim strShortSrcDir As String
|
||
Dim strShortDestDir As String
|
||
Dim strShortDestName As String
|
||
|
||
CreateTheTempDxfFile = CreateTempFile
|
||
GetShortPathAndFileName SrcFileName, strShortSrcDir, strShortSrcName
|
||
GetShortPathAndFileName CreateTheTempDxfFile, strShortDestDir, strShortDestName
|
||
|
||
Call VerInstallFile(VIFF_FORCEINSTALL, strShortSrcName, strShortDestName, strShortSrcDir, strShortDestDir, 0&, 0&, 0&)
|
||
|
||
End Function
|
||
|
||
'-----------------------------------------------------------
|
||
' FUNCTION: GetFileName
|
||
'
|
||
' Return the filename portion of a path
|
||
'
|
||
'-----------------------------------------------------------
|
||
'
|
||
Private Function GetShortPathAndFileName(ByVal SrcFileName As String, ByRef strPath As String, ByRef strFileName As String)
|
||
Dim iSep As Integer
|
||
|
||
strPath = ""
|
||
strFileName = GetShortPathName(SrcFileName)
|
||
iSep = InStr(strFileName, "\")
|
||
Do Until iSep = 0
|
||
strPath = strPath & Left(strFileName, iSep)
|
||
strFileName = Right(strFileName, Len(strFileName) - iSep)
|
||
|
||
iSep = InStr(strFileName, "\")
|
||
Loop
|
||
|
||
End Function
|
||
|
||
|
||
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
||
' Name : CreateTempFile
|
||
' Purpose :
|
||
' Parameters : NA
|
||
' Return val : NA
|
||
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
||
Private Function CreateTempFile() As String
|
||
Const lLen As Long = 255
|
||
Dim lRet As Long
|
||
Dim sTmpPath As String
|
||
Dim sTmpFile As String
|
||
|
||
sTmpPath = Space$(lLen)
|
||
sTmpFile = Space$(lLen)
|
||
CreateTempFile = ""
|
||
|
||
lRet = GetTempPath(lLen, sTmpPath)
|
||
If lRet > 0 Then
|
||
sTmpPath = Left(sTmpPath, lRet)
|
||
lRet = GetTempFileName(sTmpPath, "~LP", 0, sTmpFile) 'return: 0-> error
|
||
If lRet > 0 Then
|
||
CreateTempFile = Left(sTmpFile, Len(Trim(sTmpFile)) - 1)
|
||
End If
|
||
End If
|
||
End Function
|
||
|
||
|
||
'-----------------------------------------------------------
|
||
' FUNCTION GetShortPathName
|
||
'
|
||
' Retrieve the short pathname version of a path possibly
|
||
' containing long subdirectory and/or file names
|
||
'-----------------------------------------------------------
|
||
Function GetShortPathName(ByVal strLongPath As String) As String
|
||
Const cchBuffer = 300
|
||
Dim strShortPath As String
|
||
Dim lResult As Long
|
||
|
||
On Error GoTo 0
|
||
strShortPath = String(cchBuffer, Chr$(0))
|
||
lResult = OSGetShortPathName(strLongPath, strShortPath, cchBuffer)
|
||
If lResult = 0 Then
|
||
Error 53 ' File not found
|
||
Else
|
||
GetShortPathName = StripTerminator(strShortPath)
|
||
End If
|
||
End Function
|
||
|
||
'-----------------------------------------------------------
|
||
' FUNCTION: StripTerminator
|
||
'
|
||
' Returns a string without any zero terminator. Typically,
|
||
' this was a string returned by a Windows API call.
|
||
'
|
||
' IN: [strString] - String to remove terminator from
|
||
'
|
||
' Returns: The value of the string passed in minus any
|
||
' terminating zero.
|
||
'-----------------------------------------------------------
|
||
Function StripTerminator(ByVal strString As String) As String
|
||
Dim intZeroPos As Integer
|
||
|
||
intZeroPos = InStr(strString, Chr$(0))
|
||
If intZeroPos > 0 Then
|
||
StripTerminator = Left$(strString, intZeroPos - 1)
|
||
Else
|
||
StripTerminator = strString
|
||
End If
|
||
End Function
|
||
|
||
|
||
Public Sub SetOnTop(frm As Form, OnTop As TopStatus)
|
||
If OnTop = AlwaysOnTop Then
|
||
Call SetWindowPos(frm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
|
||
Else
|
||
Call SetWindowPos(frm.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
|
||
End If
|
||
End Sub
|
||
|
||
|
||
|
||
Public Sub ExecuteAndWait(strFile As String, strParameters As String, Optional hwnd As Long = 0, Optional nSHow As Long = SW_SHOW, Optional blnWait As Boolean = True, Optional ByRef ProzessID As Long)
|
||
Dim Retval As Long, ShExInfo As SHELLEXECUTEINFO
|
||
|
||
' Startoptionen festlegen
|
||
With ShExInfo
|
||
.cbSize = Len(ShExInfo)
|
||
.fMask = SEE_MASK_NOCLOSEPROCESS ' SEE_MASK_FLAG_NO_UI Or SEE_MASK_CLASSNAME Or SEE_MASK_NOCLOSEPROCESS
|
||
.hwnd = hwnd
|
||
.lpVerb = "open"
|
||
.lpFile = strFile
|
||
.lpParameters = strParameters
|
||
.lpDirectory = "c:\"
|
||
.nSHow = nSHow
|
||
End With
|
||
|
||
' Programm ausf<73>hren
|
||
Retval = ShellExecuteEx(ShExInfo)
|
||
If Retval = 0 Then
|
||
|
||
' bei Fehler Text ausgeben
|
||
Select Case ShExInfo.hInstApp
|
||
Case SE_ERR_ACCESSDENIED
|
||
Err.Raise 5, "ShellExecuteEx", "Zugriff verweigert"
|
||
Case SE_ERR_FNF
|
||
Err.Raise 5, "ShellExecuteEx", "Datei nicht gefunden"
|
||
Case SE_ERR_NOASSOC
|
||
Err.Raise 5, "ShellExecuteEx", "Datei ist mit keinem Programm verkn<6B>pft"
|
||
End Select
|
||
Else
|
||
|
||
' andernfalls Programmdaten ausgeben
|
||
Debug.Print "Datei gestartet: " & ShExInfo.lpFile
|
||
Debug.Print "Dateiklasse: " & ShExInfo.lpClass
|
||
Debug.Print "Prozess Handle: " & ShExInfo.hProcess
|
||
Debug.Print "Instanz Handle:" & ShExInfo.hInstApp
|
||
End If
|
||
|
||
If blnWait Then
|
||
' warten, bis die Anwendung beendet wird
|
||
Do
|
||
DoEvents
|
||
Loop Until WaitForSingleObject(ShExInfo.hProcess, 0) <> WAIT_TIMEOUT
|
||
End If
|
||
ProzessID = ShExInfo.hProcess
|
||
End Sub
|
||
|
||
|
||
|
||
|
||
Public Function WinSysDir() As String
|
||
Dim strLen As String
|
||
Dim sDirBuf As String * 255
|
||
strLen = GetSystemDirectory(sDirBuf, 255)
|
||
WinSysDir = Left$(sDirBuf, strLen)
|
||
End Function
|
||
|
||
|
||
|
||
Public Function KillProcessByName(NameProcess As String, blnJustCount As Boolean) As Integer
|
||
|
||
Const PROCESS_ALL_ACCESS = &H1F0FFF
|
||
Const TH32CS_SNAPPROCESS As Long = 2&
|
||
|
||
Dim uProcess As PROCESSENTRY32
|
||
Dim RProcessFound As Long
|
||
Dim hSnapshot As Long
|
||
Dim SzExename As String
|
||
Dim ExitCode As Long
|
||
Dim MyProcess As Long
|
||
Dim AppKill As Boolean
|
||
Dim AppCount As Integer
|
||
Dim i As Integer
|
||
Dim WinDirEnv As String
|
||
|
||
|
||
AppCount = 0
|
||
|
||
uProcess.dwSize = Len(uProcess)
|
||
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
|
||
RProcessFound = ProcessFirst(hSnapshot, uProcess)
|
||
|
||
Do
|
||
|
||
i = InStr(1, uProcess.szexeFile, Chr(0))
|
||
SzExename = LCase$(Left$(uProcess.szexeFile, i - 1))
|
||
WinDirEnv = Environ("Windir") + "\"
|
||
WinDirEnv = LCase$(WinDirEnv)
|
||
|
||
Debug.Print uProcess.th32ProcessID & "=" & SzExename
|
||
|
||
If Right$(LCase(SzExename), Len(NameProcess)) = LCase$(NameProcess) Then
|
||
AppCount = AppCount + 1
|
||
If blnJustCount = False Then
|
||
MyProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
|
||
AppKill = TerminateProcess(MyProcess, ExitCode)
|
||
Call CloseHandle(MyProcess)
|
||
End If
|
||
End If
|
||
|
||
RProcessFound = ProcessNext(hSnapshot, uProcess)
|
||
|
||
KillProcessByName = AppCount
|
||
|
||
Loop While RProcessFound
|
||
Call CloseHandle(hSnapshot)
|
||
|
||
End Function
|
||
|
||
|
||
Public Function IsInIDE() As Boolean
|
||
Dim strPath As String
|
||
Dim lRet As Long
|
||
|
||
IsInIDE = False
|
||
strPath = Space$(MAX_PATH)
|
||
lRet = GetModuleFileName(App.hInstance, strPath, Len(strPath))
|
||
If lRet <> 0 Then
|
||
If LCase$(Mid$(strPath, lRet - 6, 7)) = "vb6.exe" Then
|
||
IsInIDE = True
|
||
End If
|
||
End If
|
||
End Function
|
||
|
||
Public Sub SetWindowTopMost(hwnd As Long)
|
||
'Set the window position to topmost
|
||
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
|
||
End Sub
|
||
|
||
|
||
Public Function WaitShell(Cmdline As String, Optional Mode As Long = vbNormalFocus, _
|
||
Optional Timeout As Long = INFINITE, Optional Terminate As Boolean = True)
|
||
|
||
Dim pid As Long, pHnd As Long, ret As Long, Merk As Date
|
||
Dim uProc As PROCESS_INFORMATION
|
||
Dim uStart As STARTUPINFO
|
||
|
||
' Initialize data
|
||
uStart.cb = Len(uStart)
|
||
uStart.wShowWindow = Mode
|
||
uStart.dwFlags = 1
|
||
|
||
' Start the shelled application:
|
||
pid = CreateProcess(0&, Cmdline, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, uStart, uProc)
|
||
g_ProcessId = uProc.hProcess
|
||
|
||
' If pid <> 0 Then
|
||
'' Wait for the shelled application to finish:
|
||
' Merk = Now + Timeout / 86400 ' seconds
|
||
' Do While True
|
||
' Ret = WaitForSingleObject(uProc.hProcess, 0)
|
||
' If Ret <> WAIT_TIMEOUT Then Exit Do
|
||
' If Timeout <> INFINITE And Merk < Now Then Exit Do
|
||
' DoEvents
|
||
' Loop
|
||
' If Ret = 0 Then
|
||
' WaitShell = True
|
||
' Else
|
||
' If Terminate Then Ret = TerminateProcess(uProc.hProcess, 0&)
|
||
' WaitShell = Ret
|
||
' End If
|
||
' Ret = CloseHandle(pHnd)
|
||
' Else
|
||
' WaitShell = Ret
|
||
' End If
|
||
|
||
End Function
|
||
|
||
|
||
|
||
' Screenshot erstellen und ggf. als Bitmap speichern
|
||
Public Sub DoSnapshot(Optional ByVal bActiveWindow As Boolean = False, _
|
||
Optional ByVal sFile As String = "")
|
||
|
||
On Error Resume Next
|
||
' Der Parameter bActiveWindow legt fest, ob ein Screenshot
|
||
' f<>r das aktuelle Fenster (True) oder f<>r gesamten
|
||
' Windows-Desktop (False)erstellt werden soll
|
||
|
||
' Wird f<>r "sFile" ein Dateiname angegeben wird der
|
||
' Screenshot sofort als Bitmap gespeichert
|
||
|
||
Const KEYEVENTF_KEYUP = &H2
|
||
Const VK_MENU = &H12
|
||
Const VK_SNAPSHOT = &H2C
|
||
|
||
' Screenshot erstellen ...
|
||
If bActiveWindow Then keybd_event VK_MENU, 0, 0, 0 ' ALT-Taste
|
||
keybd_event VK_SNAPSHOT, 0, 0, 0 ' Druck-Taste
|
||
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
|
||
If bActiveWindow Then keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
|
||
DoEvents
|
||
|
||
' ... und als Bild speichern
|
||
If sFile <> "" Then
|
||
SavePicture Clipboard.getData, sFile
|
||
End If
|
||
End Sub
|