My code is thread bare

[Anonymous]

Im trying to populate a couple combo boxes and its taking quite a bit of
time. So, I was wondering if you can create threaded processes in VBA to
gather the info in the background so my interface comes up faster.

[Anonymous]

Nope.

--
http://www.acadx.com
Win an autographed copy of
"Mastering AutoCAD 2000 Objects"
by Dietmar Rudolph

"Jade Jacobsen" wrote in message
news:5BB4D09CF0823B04914F25C2562A0E68@in.WebX.maYIadrTaRb...
> Im trying to populate a couple combo boxes and its taking quite a
bit of
> time. So, I was wondering if you can create threaded processes in
VBA to
> gather the info in the background so my interface comes up faster.
>

[Anonymous]

Hi Jade,
No, but you can use a favorite Microsoft "tactic" for forms that need longer
load times - a progress window. Of course, adding the separate window and
updating while you are already running a long process just adds more time to
the process, but I get the feeling you would like your users to know that
*something* is going on while it loads up. so, with taht in mind offer you
the only one of its kind (for VBA) - VB Designs very own:

OWNER DRAWN PROGRESS BAR

In a new VBA project insert a class module (for the example code on using
the class I left the name at it's default "Class1") then add the following
code:

'Begin Code Block
Option Explicit
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' This New Window procedures
Private Const WS_THICKFRAME = &H40000
Private Const WS_CAPTION = &HC00000

Const SW_NORMAL = 1

Private Type CREATESTRUCT
lpCreateParams As Long
hInstance As Long
hMenu As Long
hWndParent As Long
cy As Long
cx As Long
y As Long
x As Long
style As Long
lpszName As String
lpszClass As String
ExStyle As Long
End Type

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA"
_
(ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, _
lpParam As Any) As Long

Private Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function DestroyWindow Lib "user32" _
(ByVal hWnd As Long) As Long

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Rectangle functions (the meter)
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function DrawEdge Lib "user32" _
(ByVal hdc As Long, qrc As RECT, ByVal edge As Long, _
ByVal grfFlags As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function FillRect Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
'This next declare is used only to slow the loop down in
'The procedure "ProgressMeterPos"
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Const BDR_SUNKENOUTER = &H2
'Want a Raised look?
Private Const BDR_RAISEDINNER = &H4
'How about both?
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
'You have to have these
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
'To get this
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
'The Rectangle type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private lngHdc As Long
Private RC As RECT
Private FillRC As RECT
Private lngFill As Long
Private lngBackColor As Long
Dim lngMax As Long
Dim lngHwnd As Long
Dim strCaption As String
'The caption for the new window
Public Property Let Caption(strCap As String)
strCaption = strCap
End Property

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' | Max is the maximum number in your For Next |
' | Loop, you must provide this value prior to |
' | Calling ProgressMeterPos! |
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Property Let Max(MaxCount As Long)
lngMax = MaxCount
End Property
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' | This sets the color of the progress fill |
' | value can be 0 to 24 |
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Property Let FillColor(lngIndex As Long)
lngFill = lngIndex
End Property
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' | This sets the color of the progress |
' | background value can be 0 to 24 |
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Property Let BackColor(lngIndex As Long)
lngBackColor = lngIndex
End Property
'Just to be sure, destroy the window!
Private Sub Class_Terminate()
If lngHwnd <> 0 Then
DestroyWindow lngHwnd
End If
End Sub

Public Sub ShowProgressWindow()
Dim CS As CREATESTRUCT
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
'Looks can be decieving, must of this call does not apply
'to us! We are not going to use the window for anything but
'display! If you have trouble with #32770 try STATIC
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
lngHwnd = CreateWindowEx(WS_THICKFRAME, "#32770", strCaption, _
WS_CAPTION, 500, 100, 250, 60, 0&, 0, 0, CS)
ShowWindow lngHwnd, SW_NORMAL
lngHdc = GetDC(lngHwnd)
SetRect RC, 5, 5, 240, 25
FillRect lngHdc, RC, GetSysColorBrush(lngBackColor)
DrawEdge lngHdc, RC, BDR_SUNKENOUTER, BF_RECT
End Sub
'Goodbye window!
Public Sub DestroyProgressWindow()
DestroyWindow lngHwnd
End Sub

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' | This is the procedure to position the progress |
' | Rectangle (FillRC), the arguments are the for |
' |The current count, and a optional sleep interval|
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Sub ProgressMeterPos(lngCnt As Long, Optional lngPause As Long)
Dim lngPos As Long
lngPos = lngCnt / lngMax * 239
If Not lngPos < 6 Then
SetRect FillRC, 5, 6, lngPos, 24
FillRect lngHdc, FillRC, GetSysColorBrush(lngFill)
If Not IsMissing(lngPause) Then
Sleep lngPause
End If
End If
End Sub
'End Code block

'Begin code block
Option Explicit
Dim objcls As Class1 'if you named the class something else, be sure to
'change this
Dim blnCancel As Boolean
Private Sub CommandButton1_Click()
blnCancel = True
End Sub

Private Sub CommandButton2_Click()
Call Test
End Sub

Public Sub Test()
Dim lngcounter As Long
Set objcls = New Class1
objcls.Caption = "Progress Bar"
objcls.Max = ThisDrawing.ModelSpace.Count
objcls.BackColor = 0
objcls.FillColor = 12
objcls.ShowProgressWindow
For lngcounter = 1 To ThisDrawing.ModelSpace.Count - 1
DoEvents
If blnCancel Then
blnCancel = False
Exit For
End If
ThisDrawing.ModelSpace.Item(lngcounter).Layer = 0
Application.Update
objcls.ProgressMeterPos lngcounter
Next
Set objcls = Nothing
End Sub

Private Sub UserForm_Initialize()
CommandButton1.Caption = "Cancel"
CommandButton2.Caption = "Run Test"
End Sub
'End code block

Randall Rath
VB Design
http://www.vbdesign.net/cadpages/