| |
Option Explicit
Private Const PIX_Factor As Double = 0.748
Private Const SPI_GETWORKAREA = 48
Private Const GWL_STYLE As Long = -16
Private Const WS_CAPTION As Long = &HC00000
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private m_hwndForm As Long
Private m_sngFrmBarHeight As Single
Private m_sngWorkAreaWidth As Single
Private m_sngWorkAreaHeight As Single
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias _
"FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal _
hwnd As Long, lpRect As RECT) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal _
uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni _
As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex _
As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex _
As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal _
hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetFocusAPI Lib "user32" Alias _
"SetFocus" (ByVal hwnd As Long) As Long
Private Sub UserForm_Initialize()
Dim nStyle As Long
m_sngFrmBarHeight = Me.Height - Me.InsideHeight
m_hwndForm = FindWindow("ThunderDFrame", Me.Caption)
nStyle = GetWindowLong(m_hwndForm, GWL_STYLE)
nStyle = nStyle And Not WS_CAPTION
SetWindowLong m_hwndForm, GWL_STYLE, nStyle
DrawMenuBar m_hwndForm
m_sngFrmBarHeight = _
m_sngFrmBarHeight - ((Me.Height - Me.InsideHeight) / 2)
Call GetTextAndFormSize(Me.txtComment)
Call GetCoordinates
End Sub
Private Sub UserForm_Activate()
SetFocusAPI FindWindow("XLMAIN", _
ThisWorkbook.Application.Caption)
End Sub
Private Sub GetTextAndFormSize(ByVal TxtBox As MSForms.TextBox, _
Optional ByVal minAbsWidth As Single = 77, _
Optional ByVal minAbsHeight As Single = 15.75, _
Optional ByVal maxRelWidth As Single = 0.3, _
Optional ByVal maxRelHeight As Single = 0.3)
Dim rct As RECT
Dim wks As Worksheet
SystemParametersInfo SPI_GETWORKAREA, 0, rct, 0
m_sngWorkAreaWidth = (rct.Right - rct.Left) * PIX_Factor
m_sngWorkAreaHeight = (rct.Bottom - rct.Top) * PIX_Factor
TxtBox.Width = m_sngWorkAreaWidth * maxRelWidth
Set wks = ThisWorkbook.Worksheets(gc_WKS_Comments_Name)
With TxtBox
.Value = wks.Range(ActiveCell.Address).Value
.AutoSize = False
.SelStart = 0
End With
Set wks = Nothing
If TxtBox.Width < minAbsWidth Then TxtBox.Width = minAbsWidth
If TxtBox.Height < minAbsHeight Then TxtBox.Height = minAbsHeight
If TxtBox.Height > m_sngWorkAreaHeight * maxRelHeight Then
TxtBox.Height = m_sngWorkAreaHeight * maxRelHeight
End If
Me.Width = TxtBox.Width + (Me.Width - Me.InsideWidth)
Me.Height = TxtBox.Height + (Me.Height - Me.InsideHeight)
End Sub
Private Sub GetCoordinates()
Dim hwnd As Long
Dim rctWndPos As RECT
Dim sngWndPosLeft As Single
Dim sngWndPosTop As Single
Dim sngZoom As Single
Dim asngPosX(1) As Single
Dim asngPosY(1) As Single
Dim asngCritPoint(1) As Single
Dim alngX(1) As Long
Dim alngY(1) As Long
hwnd = FindWindow("XLMAIN", vbNullString)
If hwnd <> 0 Then
hwnd = FindWindowEx(hwnd, 0&, "XLDESK", vbNullString)
If hwnd <> 0 Then
hwnd = FindWindowEx(hwnd, 0&, "EXCEL7", vbNullString)
If hwnd = 0 Then Exit Sub
End If
End If
Call GetWindowRect(hwnd, rctWndPos)
sngWndPosLeft = rctWndPos.Left * PIX_Factor
sngWndPosTop = rctWndPos.Top * PIX_Factor
sngZoom = ActiveWindow.Zoom / 100
asngPosX(0) = sngWndPosLeft + _
(ExecuteExcel4Macro("GET.CELL(44)") * sngZoom) + _
((Me.Width - Me.InsideWidth) / 2)
asngPosX(1) = sngWndPosLeft + _
((ExecuteExcel4Macro("GET.CELL(42)")) * sngZoom) - _
Me.Width + ((Me.Width - Me.InsideWidth) / 2)
asngPosY(0) = sngWndPosTop + _
((ExecuteExcel4Macro("GET.CELL(43)")) * sngZoom) + _
m_sngFrmBarHeight
asngPosY(1) = sngWndPosTop + _
((ExecuteExcel4Macro("GET.CELL(45)")) * sngZoom) + _
m_sngFrmBarHeight - Me.Height
asngCritPoint(0) = m_sngWorkAreaWidth - Me.Width
asngCritPoint(1) = m_sngWorkAreaHeight - Me.Height
alngX(0) = Abs(CBool(ga_DefaultPos(0)))
alngX(1) = Abs(1 + CBool(ga_DefaultPos(0)))
alngY(0) = Abs(CBool(ga_DefaultPos(1)))
alngY(1) = Abs(1 + CBool(ga_DefaultPos(1)))
Me.Left = GetPosition(asngPosX(alngX(0)), _
asngPosX(alngX(1)), asngCritPoint(0), 0)
Me.Top = GetPosition(asngPosY(alngY(0)), _
asngPosY(alngY(1)), asngCritPoint(1), 1)
End Sub
Private Function GetPosition(ByVal Pos1 As Single, _
ByVal Pos2 As Single, ByVal CritPoint As Single, _
ByVal DefaultPos As Long) As Single
Select Case True
Case (Pos1 > 0 And Pos1 < CritPoint): GetPosition = Pos1
Case (Pos2 > 0 And Pos2 < CritPoint): GetPosition = Pos2
Case Else: GetPosition = CritPoint / 2
End Select
If GetPosition = Pos2 Then
ga_DefaultPos(DefaultPos) = Not ga_DefaultPos(DefaultPos)
End If
End Function
Private Sub txtComment_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
If m_hwndForm = 0 Then Exit Sub
ReleaseCapture
SendMessage m_hwndForm, WM_NCLBUTTONDOWN, HTCAPTION, 0
SetFocusAPI FindWindow("XLMAIN", vbNullString)
End Sub
|
|
Vorheriger Tipp
Zum Seitenanfang 