-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathMGENERAL.BAS
182 lines (167 loc) · 7.29 KB
/
MGENERAL.BAS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
Attribute VB_Name = "mGeneral"
Option Explicit
Public Type POINTAPI
x As Long
y As Long
End Type
Private Const DFC_SCROLL = 3
Private Const DFCS_SCROLLSIZEGRIP = &H8&
Private Declare Function DrawFrameControl Lib "user32" (ByVal lhDC As Long, tR As RECT, ByVal eFlag As Long, ByVal eStyle As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CYHSCROLL = 3
Private Const SM_CXVSCROLL = 2
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 Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Public Const WS_HSCROLL = &H100000
Private 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 Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Const SWP_FORCECALCSIZE = SWP_NOMOVE Or SWP_NOACTIVATE Or SWP_NOOWNERZORDER Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, _
ByVal lpszWindow As String) 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 Const EC_LEFTMARGIN = &H1
Private Const EC_RIGHTMARGIN = &H2
Private Const EC_USEFONTINFO = &HFFFF&
Private Const EM_SETMARGINS = &HD3&
Private Const EM_GETMARGINS = &HD4&
Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const LB_SETTABSTOPS = &H192
Private Declare Function GetDialogBaseUnits Lib "user32" () As Long
Private Property Get EdithWnd(ByVal ctl As Control) As Long
If TypeName(ctl) = "ComboBox" Then
EdithWnd = FindWindowEx(ctl.hwnd, 0, "EDIT", vbNullString)
ElseIf TypeName(ctl) = "TextBox" Then
EdithWnd = ctl.hwnd
End If
End Property
Public Property Let RightMargin(ByVal ctl As Control, ByVal lMargin As Long)
Dim lhWnd As Long
lhWnd = EdithWnd(ctl)
If (lhWnd <> 0) Then
SendMessageLong lhWnd, EM_SETMARGINS, EC_RIGHTMARGIN, lMargin * &H10000
End If
End Property
Public Property Get RightMargin(ByVal ctl As Control) As Long
Dim lhWnd As Long
lhWnd = EdithWnd(ctl)
If (lhWnd <> 0) Then
RightMargin = SendMessageLong(lhWnd, EM_GETMARGINS, 0, 0) \ &H10000
End If
End Property
Public Property Let LeftMargin(ByVal ctl As Control, ByVal lMargin As Long)
Dim lhWnd As Long
lhWnd = EdithWnd(ctl)
If (lhWnd <> 0) Then
SendMessageLong lhWnd, EM_SETMARGINS, EC_LEFTMARGIN, lMargin
End If
End Property
Public Property Get LeftMargin(ByVal ctl As Control) As Long
Dim lhWnd As Long
lhWnd = EdithWnd(ctl)
If (lhWnd <> 0) Then
LeftMargin = (SendMessageLong(lhWnd, EM_GETMARGINS, 0, 0) And &HFFFF&)
End If
End Property
Public Sub SizeGrip(ByVal hdc As Long, ByVal x As Long, ByVal y As Long)
Dim tR As RECT
Dim hBr As Long
Static m_tRLast As RECT
tR.left = x - GetSystemMetrics(SM_CXVSCROLL)
tR.top = y - GetSystemMetrics(SM_CYHSCROLL)
tR.right = x
tR.bottom = y
If m_tRLast.right - m_tRLast.left > 0 Then
If Not (EqualRect(m_tRLast, tR) = 1) Then
hBr = GetSysColorBrush(vbButtonFace And &H1F&)
FillRect hdc, m_tRLast, hBr
DeleteObject hBr
End If
End If
DrawFrameControl hdc, tR, DFC_SCROLL, DFCS_SCROLLSIZEGRIP
LSet m_tRLast = tR
End Sub
Public Sub HorizontalSeparator(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal width As Long)
Dim tJunk As POINTAPI
Dim hPen As Long
Dim hPenOld As Long
hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbButtonShadow And &H1F&))
hPenOld = SelectObject(hdc, hPen)
MoveToEx hdc, x, y, tJunk
LineTo hdc, x + width, y
SelectObject hdc, hPenOld
DeleteObject hPen
hPen = CreatePen(PS_SOLID, 1, GetSysColor(vb3DHighlight And &H1F&))
hPenOld = SelectObject(hdc, hPen)
MoveToEx hdc, x, y + 1, tJunk
LineTo hdc, x + width, y + 1
SelectObject hdc, hPenOld
DeleteObject hPen
End Sub
Public Property Get FileExists(ByVal sFile As String) As Boolean
On Error Resume Next
sFile = Dir(sFile)
FileExists = ((Err.Number = 0) And sFile <> "")
On Error GoTo 0
End Property
Public Function NormalizePath(ByRef sPath As String) As String
If Len(sPath) > 1 Then
If Not (StrComp(right$(sPath, 1), "\") = 0) Then
sPath = sPath & "\"
End If
End If
NormalizePath = sPath
End Function
Public Sub AddStyle(ByVal hWndA As Long, ByVal lStyle As Long)
Dim lS As Long
lS = GetWindowLong(hWndA, GWL_STYLE)
lS = lS Or lStyle
SetWindowLong hWndA, GWL_STYLE, lS
SetWindowPos hWndA, 0, 0, 0, 0, 0, SWP_FORCECALCSIZE
End Sub
Public Sub SetHorizontalExtent(ByVal hWndA As Long, ByVal iPixels As Integer)
On Error Resume Next
SendMessageLong hWndA, LB_SETHORIZONTALEXTENT, iPixels, 0
Err.Clear
On Error GoTo 0
End Sub
Public Sub TabStop(ByVal hWndA As Long, lTabPositions() As Long)
Dim lCount As Long
Dim lBaseUnitX As Long
Dim lBaseUnit As Long
Dim lTabDlgUnitPos() As Long
Dim i As Long
On Error Resume Next
lCount = UBound(lTabPositions) - LBound(lTabPositions) + 1
If lCount > 0 Then
lBaseUnit = GetDialogBaseUnits()
lBaseUnitX = lBaseUnit And &HFFFF&
ReDim lTabDlgUnitPos(0 To lCount - 1) As Long
For i = 0 To lCount - 1
lTabDlgUnitPos(i) = (lTabPositions(i + LBound(lTabPositions)) * 4) / lBaseUnitX
Next i
i = SendMessage(hWndA, LB_SETTABSTOPS, lCount, lTabDlgUnitPos(0))
End If
End Sub