AW: Mit VBScript die höchste Excel-Version starten
31.05.2014 11:47:11
Nepumuk
Hallo Ewald,
teste mal:
' **********************************************************************
' Modul: Start Typ: Userform
' **********************************************************************
Option Explicit
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long
Private Declare Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function SendMessageA Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
Private Declare Function SetWindowRgn Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long
Private Declare Function ScreenToClient Lib "user32.dll" ( _
ByVal hWnd As Long, _
lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
ByVal hWnd As Long, _
lpRect As RECT) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32.dll" ( _
lpRect As RECT) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const GWL_EXSTYLE = -20&
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Const GWL_STYLE = -16
Private Const WS_CAPTION = &HC00000
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const GC_CLASSNAMEUSERFORM As String = "ThunderDFrame"
Private mlngFormHwnd As Long
Private Sub CommandButton1_Click()
Unload Me
Application.WindowState = xlMaximized
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.WindowState = xlMaximized
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "WM2014.xlsm"
ThisWorkbook.Close SaveChanges:=True
Unload Me
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click()
ThisWorkbook.FollowHyperlink Address:= _
ThisWorkbook.Path & "\" & "Startinfo.htm", NewWindow:=True
End Sub
Private Sub CommandButton4_Click()
ThisWorkbook.FollowHyperlink Address:= _
ThisWorkbook.Path & "\" & "Kurzinfo.htm", NewWindow:=True
End Sub
Private Sub UserForm_Activate()
SetLayeredWindowAttributes FormHwnd, ByVal 0&, 255&, LWA_ALPHA
End Sub
Private Sub UserForm_Initialize()
Dim lngStyle As Long
Dim udtRect As RECT, lpBR As POINTAPI
FormHwnd = FindWindowA(GC_CLASSNAMEUSERFORM, Caption)
lngStyle = GetWindowLongA(FormHwnd, GWL_EXSTYLE)
lngStyle = lngStyle Or WS_EX_LAYERED
SetWindowLongA FormHwnd, GWL_EXSTYLE, lngStyle
SetLayeredWindowAttributes FormHwnd, ByVal 0&, 0&, LWA_ALPHA
lngStyle = GetWindowLongA(FormHwnd, GWL_STYLE)
lngStyle = lngStyle And Not WS_CAPTION
SetWindowLongA FormHwnd, GWL_STYLE, lngStyle
DrawMenuBar FormHwnd
GetWindowRect FormHwnd, udtRect
lpBR.X = udtRect.Right
lpBR.Y = udtRect.Bottom
ScreenToClient FormHwnd, lpBR
With udtRect
.Bottom = lpBR.Y - 18
.Left = 4
.Right = lpBR.X
.Top = 4
End With
SetWindowRgn FormHwnd, CreateRectRgnIndirect(udtRect), True
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
ReleaseCapture
SendMessageA FormHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
Friend Property Get FormHwnd() As Long
FormHwnd = mlngFormHwnd
End Property
Private Property Let FormHwnd(ByVal pvlngFormHwnd As Long)
mlngFormHwnd = pvlngFormHwnd
End Property
Hat aber eine Nebenwirkung, das Userform zuckt nach dem Öffnen einmal kurz. Besser werde ich es nicht hinbekommen.
Gruß
Nepumuk