Do Loop - Left- & Right-Click

J

jbrouse

Active Member
Joined
Apr 28, 2005
Messages
329
Greetings,

I have posted on this a few times now, but as of yet, no one has been able to assist me. Perhaps the code below will help people get started.

Here is what the code should do. If my ToggleButton, named "Edit", is set to True, then it should run the sub "Alter" below. At this point, the user has the following options as long as Edit.Value = True:

Right-Click, which should run function Change_Shape
Left-Click, which should run function Create_Shape
Press ESC, which will exit the function completely and set Edit.Value = False

1) The code works, with the following problems. Right-clicking causes Change_Shape to run infinitely.

2) Left-clicking works for the most part, but randomly, it seems to freeze and I can't break out of the code unless I hit ESC.

Can anyone assist me in modifying the Alter function at the bottom to avoid these problems? It would be greatly appreciated. I apologize for the long posting of code, but it is necessary to get the code to work properly.


In a standard module:

Code: 
Option Explicit

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 Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const ListBoxName As String = "Origin_X_Y"

Private x As Single, y As Single
Private CurPos As POINTAPI

Public CancelLoop As Boolean


Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function GetAsyncKeyState Lib "user32" _
        (ByVal vKey As Long) As Integer
        
Private Const VK_LBUTTON = &H1
Private Const VK_RBUTTON = &H2
Private Const VK_SHIFT = &H10
Private Const VK_CONTROL = &H11
Private Const VK_ESCAPE = &H1B

Private Type POINTAPI
    x As Long
    y As Long
End Type

Declare Function GetKeyState Lib "user32.dll" _
    (ByVal KeyCode As Long) As Integer
Dim ShiftKeyState As Integer
Public counter As Integer
Public MyShift As Integer
Public MaxVal As Integer

Sub SetCounter()
    
    Dim MyVal As Integer
    Dim sh As Shape
    
    counter = 1
    
    MaxVal = 0
    
    For Each sh In ActiveSheet.Shapes
        If Left(sh.Name, 2) = "Pr" Then
            MyVal = Right(sh.Name, 2)
            If MyVal > MaxVal Then
                MaxVal = MyVal
            End If
        End If
    Next sh
    
    counter = MaxVal + 1

End Sub

Sub Add_Detail()

    ActiveSheet.Shapes(Application.Caller).Select

    Const PopUpCommandBarName As String = "Edit Process"          'create the custom menu and display it
    Module1.CreatePopUp (PopUpCommandBarName)
    CommandBars(PopUpCommandBarName).ShowPopup

End Sub

Public Function GetPoints(ByRef Left_X As Single, ByRef Top_Y As Single) As Boolean
    Call AddControls(ActiveSheet)
    Call GetLeftTopXY
    ActiveSheet.OLEObjects(ListBoxName).Delete
    Application.Cursor = xlNorthwestArrow
    Call GetUserCursorPosition
    Application.Cursor = xlDefault
    Left_X = ((CurPos.x - x) * 0.75) + ActiveWindow.VisibleRange(1).Left
    Top_Y = ((CurPos.y - y) * 0.75) + ActiveWindow.VisibleRange(1).Top
    
    If GetAsyncKeyState(VK_SHIFT) < 0 Then
        MyShift = 1
    End If
    
End Function


Private Function AddControls(sh As Object) As Boolean

    On Error GoTo Err_AddControls
    
    Dim OleObj As OLEObject
    
    Application.ScreenUpdating = False
    
    If Not ListboxExists(sh) Then
        Set OleObj = sh.OLEObjects.Add(ClassType:="Forms.ListBox.1", Link:=False, _
            DisplayAsIcon:=False, Width:=1, Height:=1)
        OleObj.Name = ListBoxName
    End If
    
    Set OleObj = sh.OLEObjects(ListBoxName)
    With OleObj
        If .Left <> ActiveWindow.VisibleRange(1).Left Then .Left = ActiveWindow.VisibleRange(1).Left
        If .Top <> ActiveWindow.VisibleRange(1).Top Then .Top = ActiveWindow.VisibleRange(1).Top
        sh.Activate
        sh.Select
    End With
    
    AddControls = True
    Application.ScreenUpdating = True
    
Exit Function
Err_AddControls:
    AddControls = False
End Function

Private Function ListboxExists(sh As Object) As Boolean
    On Error Resume Next
    Dim OleObj As OLEObject
    Set OleObj = sh.OLEObjects(ListBoxName)
    ListboxExists = (Err.Number = 0)
End Function

Private Function GetLeftTopXY() As Boolean
    
    Dim XLMAINhWnd As Long, XLDESKhWnd As Long, EXCEL7hWnd As Long, F3ServerHwnd As Long
    Dim r As RECT
    
    XLMAINhWnd = FindWindow("XLMAIN", Application.Caption)
    XLDESKhWnd = FindWindowEx(XLMAINhWnd, 0, "XLDESK", vbNullString)
    EXCEL7hWnd = FindWindowEx(XLDESKhWnd, 0, "EXCEL7", vbNullString)
    F3ServerHwnd = FindWindowEx(EXCEL7hWnd, 0, "F3 Server 60000000", vbNullString)
    GetWindowRect F3ServerHwnd, r
    
    Do Until ((r.Right - r.Left) + (r.Bottom - r.Top) = 2) Or F3ServerHwnd = 0
        F3ServerHwnd = FindWindowEx(EXCEL7hWnd, F3ServerHwnd, "F3 Server 60000000", vbNullString)
        GetWindowRect F3ServerHwnd, r
    Loop
    
    If F3ServerHwnd <> 0 Then
        GetLeftTopXY = True
        x = r.Left
        y = r.Top
    End If

End Function

Private Sub GetUserCursorPosition()
    Do
        GetCursorPos CurPos
        If GetAsyncKeyState(VK_LBUTTON) < 0 Or CancelLoop = True Then
            Exit Do
        End If
    Loop
End Sub



Sub Connect_Shape()

Dim x As Single, y As Single, ShapeWidth As Single, ShapeHeight As Single
    Dim EndCon As Integer
    
    Application.ScreenUpdating = False
    
    'If ActiveSheet.Name <> "PROCESS FLOW" Then Exit Sub
    
    ShapeWidth = 20
    ShapeHeight = 20
    
    Call GetPoints(x, y)
    
    x = x - (ShapeWidth / 2)
    y = y - (ShapeHeight / 2)
    
    SetCounter
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, x, y, ShapeWidth, ShapeHeight).Name = "a0" & counter
    ActiveSheet.Shapes("a0" & counter).Select
    Selection.ShapeRange.Line.Visible = msoFalse

    Select Case Worksheets("PROCESS FLOW").Range("BL3").Value
        Case "PARTS / MATERIAL"
            ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x, y, ShapeWidth, ShapeHeight).Name = "b0" & counter
            ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x, y, ShapeWidth, ShapeHeight).Name = "c0" & counter
            GoTo Default
        Case "PROCESS"
            ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, ShapeWidth, ShapeHeight).Name = "c0" & counter
            ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, ShapeWidth, ShapeHeight).Name = "b0" & counter
        Case "INSPECTION"
            ActiveSheet.Shapes.AddShape(msoShapeDiamond, x, y, ShapeWidth, ShapeHeight).Name = "c0" & counter
            ActiveSheet.Shapes.AddShape(msoShapeDiamond, x, y, ShapeWidth, ShapeHeight).Name = "b0" & counter
        Case "PROCESS / INSPECTION"
            ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, ShapeWidth, ShapeHeight).Name = "b0" & counter
            ActiveSheet.Shapes.AddShape(msoShapeDiamond, x + 2, y + 2, ShapeWidth - 4, ShapeHeight - 4).Name = "c0" & counter
        Case "ASSEMBLY"
            ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x, y, ShapeWidth, ShapeHeight).Name = "b0" & counter
            ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x + 5.5, y + 8, ShapeWidth - 11, ShapeHeight - 11).Name = "c0" & counter
            GoTo Default
    End Select
        
        ActiveSheet.Shapes("a0" & counter).Select
        Selection.Characters.Text = counter
        With Selection.Font
                .Size = 7
            End With
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        
        ActiveSheet.Shapes("b0" & counter).Select
        Selection.ShapeRange.Fill.Visible = msoFalse
        
        ActiveSheet.Shapes("c0" & counter).Select
        Selection.ShapeRange.Fill.Visible = msoFalse
        
        
Default:
        ActiveSheet.Shapes.Range(Array("a0" & counter, "b0" & counter, "c0" & counter)).Select
        Selection.ShapeRange.Group.Name = "Pr0" & counter
    
If MyShift = 1 Then
        ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 461.25, 204#, 1.5, 22.5).Name = "C0" & counter
        ActiveSheet.Shapes("C0" & counter).Select
        Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes("Pr0" & counter).GroupItems(1), 1
        Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes("Pr0" & counter - 1).GroupItems(1), 3
            
        If Abs(ActiveSheet.Shapes("Pr0" & counter).Left - ActiveSheet.Shapes("Pr0" & counter - 1).Left) < 20 Then
            x = ActiveSheet.Shapes("Pr0" & counter - 1).Left
            ActiveSheet.Shapes("Pr0" & counter).Left = x
            y = ActiveSheet.Shapes("Pr0" & counter - 1).Top + 30
            ActiveSheet.Shapes("Pr0" & counter).Top = y
        End If
    End If
        
        ActiveSheet.Shapes("Pr0" & counter).Select
        Selection.OnAction = "Add_Detail"
        
        ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x + 35, y + 2.5, 0, 0).Name = "T0" & counter
        ActiveSheet.Shapes("T0" & counter).TextFrame.Characters.Text = "INSERT TEXT HERE"
        
        Application.ScreenUpdating = True
        
End Sub

Sub Change_Shape()

On Error Resume Next

If ActiveSheet.Name <> "PROCESS FLOW" Then Exit Sub

ActiveSheet.Shapes("ThisShape").Delete
ActiveSheet.Shapes("ThisShapeB").Delete

Select Case ActiveSheet.Range("BL3").Text
Case "PARTS / MATERIAL"
    ActiveSheet.Range("BL3").Value = "PROCESS"
    ActiveSheet.Shapes.AddShape(msoShapeOval, Range("BL3").Left + 13.25, Range("BL3").Top + 10, 22.25, 20).Name = "ThisShape"
Case "PROCESS"
    ActiveSheet.Range("BL3").Value = "INSPECTION"
    ActiveSheet.Shapes.AddShape(msoShapeDiamond, Range("BL3").Left + 13, Range("BL3").Top + 10, 22.25, 20).Name = "ThisShape"
Case "INSPECTION"
    ActiveSheet.Range("BL3").Value = "PROCESS / INSPECTION"
    ActiveSheet.Shapes.AddShape(msoShapeOval, Range("BL3").Left + 13.25, Range("BL3").Top + 10, 22.25, 20).Name = "ThisShape"
    ActiveSheet.Shapes.AddShape(msoShapeDiamond, Range("BL3").Left + 14.25, Range("BL3").Top + 10.75, 22.25 - 2, 20 - 2).Name = "ThisShapeB"
Case "PROCESS / INSPECTION"
    ActiveSheet.Range("BL3").Value = "ASSEMBLY"
    ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, Range("BL3").Left + 13.25, Range("BL3").Top + 10, 22.5, 20).Name = "ThisShape"
    ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, Range("BL3").Left + 19.25, Range("BL3").Top + 18, 11, 9).Name = "ThisShapeB"
Case "ASSEMBLY"
    ActiveSheet.Range("BL3").Value = "PARTS / MATERIAL"
    ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, Range("BL3").Left + 12.5, Range("BL3").Top + 10, 22.5, 20).Name = "ThisShape"

End Select

End Sub

Sub Alter()

    Do
        If GetAsyncKeyState(VK_RBUTTON) < 0 Then
            Change_Shape

        ElseIf GetAsyncKeyState(VK_LBUTTON) < 0 Then
            Connect_Shape
        
        ElseIf GetAsyncKeyState(VK_ESCAPE) < 0 Then
            Sheet3.Edit.Value = False
            Exit Do
        
        End If
    Loop
    
End Sub
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Sort by date Sort by votes
Have you tried entering Exit Do after the Change_Shape, as well as after the Connect_Shape? Please try it, and report back.
 
Upvote 0
If I add an Exit Do in each of those If statements, it will break out of the code, only allowing me to change or create the shape once. Then I would have to unclick and re-click edit in order to paste another shape. I want to be able to use the left-/right-click functionality in this way for the duration of Edit being toggled on.
 
Upvote 0
Try, instead:

Code: 
Sub Alter() 

    Do 
        If GetAsyncKeyState(VK_RBUTTON) < 0 Then 
            Change_Shape
            GetAsyncKeyState(VK_RBUTTON) = 0

        ElseIf GetAsyncKeyState(VK_LBUTTON) < 0 Then 
            Connect_Shape 
            GetAsyncKeyState(VK_LBUTTON) = 0
        
        ElseIf GetAsyncKeyState(VK_ESCAPE) < 0 Then 
            Sheet3.Edit.Value = False 
            Exit Do 
        
        End If 
    Loop 
    
End Sub
 
Upvote 0
The GetAsyncKeyState(VK_RBUTTON) = 0 returns a Compile Error: Function call on left-hand side of assignment must return Variant Or Object.
 
Upvote 0
Time for a VBA guru! Me, I'm just a dabbler in VB, and the logic "seemed" good, to me. But, I see that I was wrong.

Hope some other person sees your post and helps you out.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
58
tigger_na
T
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
278
huiettcm
H
Jaafar Tribak
  • Question
Date Input Mask ( Applying a Watermark to TextBox)
Replies
9
Views
2K
Davmacrat
Davmacrat
Jaafar Tribak
  • Question
Grouping UserForms [Having userforms follow each other when moved around the screen]
Replies
6
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question
MultiColor + Drag N Drop ListBox Class (Win32)
Replies
8
Views
2K
Hasson
H

Forum statistics

Threads
1,214,649
Messages
6,120,728
Members
448,987
Latest member
marion_davis

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top