Skip to content

Commit eb7f8d4

Browse files
pscbotpscbot
committed
Initial commit
0 parents  commit eb7f8d4

30 files changed

+7066
-0
lines changed

‎.gitattributes‎

Lines changed: 86 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,86 @@
1+
# VB6 source files (show diff + keep CRLF in zip download)
2+
3+
*.bas working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
4+
*.cls working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
5+
*.ctl working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
6+
*.dob working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
7+
*.dsr working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
8+
*.frm working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
9+
*.pag working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6
10+
*.vbg working-tree-encoding=CP1252 text eol=crlf
11+
*.vbl working-tree-encoding=CP1252 text eol=crlf
12+
*.vbp working-tree-encoding=CP1252 text eol=crlf
13+
*.vbr working-tree-encoding=CP1252 text eol=crlf
14+
*.vbw working-tree-encoding=CP1252 text eol=crlf
15+
16+
# Other source files (show diff + LF only in zip download)
17+
18+
*.asm text
19+
*.asp text
20+
*.bat text
21+
*.c text
22+
*.cpp text
23+
*.dsp text
24+
*.dsw text
25+
*.h text
26+
*.idl text
27+
*.java text
28+
*.js text
29+
*.manifest text
30+
*.odl text
31+
*.php text
32+
*.php3 text
33+
*.rc text
34+
*.sln text
35+
*.sql text
36+
*.vb text
37+
*.vbs text
38+
39+
# Binary
40+
41+
*.res binary
42+
*.frx binary
43+
*.ctx binary
44+
*.dsx binary
45+
*.exe binary
46+
*.dll binary
47+
*.ocx binary
48+
*.cmp binary
49+
*.pdb binary
50+
*.tlb binary
51+
*.xls binary
52+
*.doc binary
53+
*.ppt binary
54+
*.xlsx binary
55+
*.docx binary
56+
*.pptx binary
57+
*.chm binary
58+
*.hlp binary
59+
*.jpg binary
60+
*.png binary
61+
*.bmp binary
62+
*.gif binary
63+
*.ico binary
64+
*.zip binary
65+
*.cab binary
66+
*.7z binary
67+
*.gz binary
68+
69+
# Text files but keep as binary (no diff)
70+
71+
# *.cfg text
72+
# *.conf text
73+
# *.csi text
74+
# *.css text
75+
# *.csv text
76+
# *.def text
77+
# *.htm text
78+
# *.html text
79+
# *.inf text
80+
# *.ini text
81+
# *.log text
82+
# *.reg text
83+
# *.rtf text
84+
# *.txt text
85+
# *.url text
86+
# *.xml text

‎.gitignore‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
*.scc
2+
*.dca
3+
*.oca
4+
*.obj
5+
vb*.tmp
6+
@PSC*

‎AriadIFceComp.RES‎

28.6 KB
Binary file not shown.

‎AriadIFceComp.bas‎

Lines changed: 294 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,294 @@
1+
Attribute VB_Name = "basAriadIFceComp"
2+
3+
'-------------------------------'
4+
' Ariad Development Library 2.0 '
5+
'-------------------------------'
6+
' Ariad Interface Components '
7+
' Version 1.0 '
8+
'-------------------------------'
9+
' Core Routines Module '
10+
'-------------------------------'
11+
'Copyright © 1998-9 by Ariad Software. All Rights Reserved
12+
13+
'Date Created:
14+
'Last Updated:
15+
16+
Option Explicit
17+
DefInt A-Z
18+
19+
'PlaySoundA Constants
20+
Public Const SND_ASYNC = &H1 ' play asynchronously
21+
Public Const SND_NODEFAULT = &H2 ' silence not default, if sound not found
22+
Public Const SND_MEMORY = &H4 ' lpszSoundName points to a memory file
23+
24+
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
25+
26+
Public Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
27+
Public Declare Function GetActiveWindow Lib "user32" () As Long
28+
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
29+
Public Declare Function GetDesktopWindow Lib "user32" () As Long
30+
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
31+
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
32+
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
33+
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
34+
Public Declare Function PlaySoundData Lib "WINMM.DLL" Alias "PlaySoundA" (lpData As Any, ByVal hModule As Long, ByVal dwFlags As Long) As Long
35+
Public Declare Function ReleaseCapture& Lib "user32" ()
36+
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
37+
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
38+
Public Declare Function SetCapture& Lib "user32" (ByVal hWnd As Long)
39+
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
40+
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
41+
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
42+
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
43+
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
44+
45+
Public Const SW_SHOWNOACTIVATE = 4
46+
47+
Private Const HWND_TOP& = 0
48+
Private Const SWP_NOMOVE& = &H2
49+
Private Const SWP_NOACTIVATE& = &H10
50+
Private Const SWP_NOSIZE& = &H1
51+
Private Const SWP_SHOWWINDOW& = &H40
52+
53+
Public PE As ascPaintEffects
54+
55+
Public CtlCount As Long
56+
57+
Public Const ASMAIL$ = "[email protected]"
58+
Public Const ASURL$ = "http://www.users.globalnet.co.uk/~ariad/"
59+
Public Const ASURL2$ = "http://www.ariad.tsx.org/"
60+
61+
Public Const INTERR$ = "An unexpected application error has occured!"
62+
Public Const ERRTEXT$ = "If this problem continues, please contact Ariad technical support, at " + ASMAIL$ + ", quoting the above information."
63+
64+
'-------------------------------
65+
'Name : ShowPopupMenu
66+
'Created : 27/08/1999 14:39
67+
'-------------------------------
68+
'Author : Richard Moss
69+
'Organisation: Ariad Software
70+
'-------------------------------
71+
'Returns : Nothing
72+
'
73+
'-------------------------------
74+
'Updates :
75+
'
76+
'-------------------------------
77+
'---------AS-PROCBUILD 1.00.0024
78+
Public Sub ShowPopupMenu(hWndClient As Long, PopupMenu As Menu, PopupParent As Form)
79+
Dim WinRect As RECT
80+
Dim WinPoint As POINTAPI
81+
Dim X As Single, Y As Single
82+
Dim ScaleMode As ScaleModeConstants
83+
ClientToScreen PopupParent.hWnd, WinPoint
84+
GetWindowRect hWndClient, WinRect
85+
If TypeOf PopupParent Is MDIForm Then
86+
ScaleMode = vbTwips
87+
Else
88+
ScaleMode = PopupParent.ScaleMode
89+
End If
90+
X = PopupParent.ScaleX(WinRect.Left - WinPoint.X, vbPixels, ScaleMode)
91+
Y = PopupParent.ScaleY(WinRect.Bottom - WinPoint.Y, vbPixels, ScaleMode)
92+
PopupParent.PopupMenu PopupMenu, , X, Y
93+
End Sub '(Public) Sub ShowPopupMenu ()
94+
95+
'----------------------------------------------------------------------
96+
'Name : Highlight
97+
'Created : 21/08/1999 23:07
98+
'Modified :
99+
'Modified By :
100+
'----------------------------------------------------------------------
101+
'Author : Richard James Moss
102+
'Organisation: Ariad Software
103+
'----------------------------------------------------------------------
104+
Public Sub Highlight(C As Control)
105+
With C
106+
.SelStart = 0
107+
.SelLength = Len(.Text)
108+
End With
109+
End Sub '(Public) Sub Highlight ()
110+
111+
'----------------------------------------------------------------------
112+
'Name : InitPaintEffects
113+
'Created : 12/07/1999 14:51
114+
'Modified :
115+
'Modified By :
116+
'----------------------------------------------------------------------
117+
'Author : Richard James Moss
118+
'Organisation: Ariad Software
119+
'----------------------------------------------------------------------
120+
Public Sub InitPaintEffects()
121+
If PE Is Nothing Then
122+
Set PE = New ascPaintEffects
123+
End If
124+
End Sub '(Public) Sub InitPaintEffects ()
125+
126+
127+
'----------------------------------------------------------------------
128+
'Name : Main
129+
'Created : 12/07/1999 14:40
130+
'Modified :
131+
'Modified By :
132+
'----------------------------------------------------------------------
133+
'Author : Richard James Moss
134+
'Organisation: Ariad Software
135+
'----------------------------------------------------------------------
136+
Public Sub Main()
137+
Set PE = New ascPaintEffects
138+
End Sub '(Public) Sub Main ()
139+
140+
Function StartDocError$(R As Long)
141+
Dim M$
142+
If R >= 0 Then
143+
Select Case R
144+
Case 0: M$ = "System was out of memory or executable file was corrupt."
145+
Case 2: M$ = "The file was not found."
146+
Case 3: M$ = "The path was not found."
147+
Case 5: M$ = "Attempt was made to link to a task dynamically, or there was a sharing or network-protection error."
148+
Case 6: M$ = "Library required separate data segments for each task."
149+
Case 8: M$ = "There was insufficient memory to start the application."
150+
Case 10: M$ = "The Windows version was incorrect."
151+
Case 11: M$ = "The executable file was invalid. Either it was not a Windows-based application or there was an error in the .EXE image."
152+
Case 12: M$ = "Application was designed for a different operating system."
153+
Case 13: M$ = "Application was designed for MS-DOS version 4.0."
154+
Case 14: M$ = "Type of executable file was unknown."
155+
Case 15: M$ = "Attempt was made to load a real-mode application that was developed for an earlier version of Windows."
156+
Case 16: M$ = "Attempt was made to load a second instance of an executable file containing multiple data segments not marked read-only."
157+
Case 19: M$ = "Attempt was made to load a compressed executable file. The file must be decompressed before it can be loaded."
158+
Case 20: M$ = "Dynamic-link library (DLL) file was invalid. One of the DLLs required to run this application was corrupt."
159+
Case 21: M$ = "Application requires Microsoft Windows 32-bit extensions."
160+
Case 31: M$ = "No application has been associated for use with specified document."
161+
Case Else: M$ = "Unknown Error."
162+
End Select
163+
Else
164+
M$ = "Unknown error."
165+
End If
166+
StartDocError$ = M$ + Chr$(10) + Chr$(10) + "(Error Code: " + CStr(R) + ")"
167+
End Function
168+
169+
Function IsUsingLargeFonts() As Boolean
170+
Dim hWndDesk As Long, hDCDesk As Long, logPix As Long, R As Long
171+
hWndDesk = GetDesktopWindow()
172+
hDCDesk = GetDC(hWndDesk)
173+
logPix = GetDeviceCaps(hDCDesk, 88)
174+
R = ReleaseDC(hWndDesk, hDCDesk)
175+
If logPix > 96 Then IsUsingLargeFonts = -1
176+
End Function
177+
178+
Function DegreeToRad(Deg As Integer) As Single
179+
DegreeToRad = Deg / 57.295779513
180+
End Function
181+
182+
Public Function RemoveExtension$(F$)
183+
Dim R$(), E$
184+
Dim I
185+
If InStr(F$, ".") Then
186+
R$ = Split(F$, ".")
187+
For I = 0 To UBound(R$) - 1
188+
E$ = E$ + R$(I) + "."
189+
Next
190+
RemoveExtension$ = Left$(E$, Len(E$) - 1)
191+
Else
192+
RemoveExtension$ = F$
193+
End If
194+
End Function
195+
196+
Function IsInControl(ByVal hWnd As Long) As Boolean
197+
Dim P As POINTAPI
198+
GetCursorPos P
199+
If hWnd = WindowFromPoint(P.X, P.Y) Then IsInControl = -1
200+
End Function
201+
202+
Public Function GetFile$(FP$)
203+
Dim R$()
204+
If Len(FP$) Then
205+
R$() = Split(FP$, "\")
206+
GetFile$ = R$(UBound(R$))
207+
End If
208+
End Function
209+
210+
Sub PlaySnd(SndName$, m_PlaySounds As Boolean)
211+
Dim bySound() As Byte
212+
On Error Resume Next
213+
If m_PlaySounds Then
214+
bySound = LoadResData(SndName$, 100)
215+
If Err = 0 And UBound(bySound) > 0 Then
216+
PlaySoundData bySound(0), 0, SND_MEMORY + SND_ASYNC + SND_NODEFAULT
217+
End If
218+
End If
219+
On Error GoTo 0
220+
End Sub
221+
222+
Public Function ShowTip(ByVal Tip$, ByVal hWnd As Long, Optional ByVal Font As StdFont) As Boolean
223+
Const DX = -2 ' Offset from the mouse position.
224+
Const DY = 18
225+
Dim X As Long, Y As Long
226+
Dim PT As POINTAPI
227+
On Error Resume Next
228+
GetCursorPos PT
229+
X = PT.X
230+
Y = PT.Y
231+
HideTip
232+
With frmTooltip
233+
If Not Font Is Nothing Then
234+
Set .lblTip.Font = Font
235+
Set .Font = Font
236+
End If
237+
.lblTip.Width = .TextWidth(Tip$)
238+
.lblTip.Caption = Tip$
239+
.lblTip.Refresh
240+
.CtlHWnd = hWnd
241+
.Move (X + DX) * Screen.TwipsPerPixelX, (Y + DY) * Screen.TwipsPerPixelY, .lblTip.Width + (8 * Screen.TwipsPerPixelX), .lblTip.Height + (5 * Screen.TwipsPerPixelY)
242+
.tmrTip.Enabled = 0
243+
.tmrTip.Enabled = -1
244+
If .Left + .Width > Screen.Width Then .Left = Screen.Width - .Width
245+
If .Top + .Height > Screen.Height Then .Top = Screen.Height - .Height
246+
SetWindowPos .hWnd, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
247+
End With
248+
ShowTip = -1
249+
On Error GoTo 0
250+
End Function
251+
252+
Function DefineAccessKey$(Caption$)
253+
Dim P, N
254+
Dim C$
255+
N = 1
256+
Do
257+
P = InStr(N, Caption$, "&")
258+
If P Then
259+
C$ = Mid$(Caption$, P + 1, 1)
260+
If C$ <> "&" Then DefineAccessKey$ = DefineAccessKey$ + C$
261+
N = P + 1
262+
End If
263+
Loop Until P = 0
264+
End Function
265+
266+
267+
Public Sub HideTip()
268+
On Error Resume Next
269+
Unload frmTooltip
270+
On Error GoTo 0
271+
End Sub
272+
273+
274+
Public Sub Pointer(V)
275+
Screen.MousePointer = V
276+
End Sub
277+
278+
279+
280+
Public Function UltimateParent(Ctl As Object) As Object
281+
Dim O As Object, T As Object
282+
On Error Resume Next
283+
Set T = Ctl.Parent
284+
Set UltimateParent = T
285+
Do
286+
Set O = T.Parent
287+
If Not O Is Nothing Then
288+
Set T = O
289+
Set UltimateParent = O
290+
End If
291+
Loop Until O Is Nothing
292+
On Error GoTo 0
293+
End Function
294+

0 commit comments

Comments
 (0)