Robot Arm in VBA

wall-e

New Member
Joined
Apr 17, 2013
Messages
2
Hi everyone, I am trying to model a two-line robotic arm in Excel VBA where I have an object and I specify the pickup and drop-off positions, and the arm moves with constant angular velocities to reach the object, pick it up, and then drop it off. It will look similar to this;

Yasser's Virtual Robot Arm Using Visual Basic 6.0 - YouTube

I'm not sure how to go about this vba program. Any help would be appreciated.
Thank you!
 

ClimoC

Well-known Member
Joined
Aug 21, 2009
Messages
584
Nearly sh@t myself in anticipation while the page loaded...

Looks to me to be a combination of the WinAPI32 Mouse position calls. I tried it once but it was really unstable (I was trying to emulate 'drag'n'drop' in a custom Workbook) but that might have been my code.

Essentially, in pixels I believe, it calls back the (x,y) position of the mouse pointer. From there, you just scale the results into Height and Width on a userform.
 

wall-e

New Member
Joined
Apr 17, 2013
Messages
2
Nearly sh@t myself in anticipation while the page loaded...

Looks to me to be a combination of the WinAPI32 Mouse position calls. I tried it once but it was really unstable (I was trying to emulate 'drag'n'drop' in a custom Workbook) but that might have been my code.

Essentially, in pixels I believe, it calls back the (x,y) position of the mouse pointer. From there, you just scale the results into Height and Width on a userform.
Thanks so much for the reply,
I'm honestly really new to VBA, and programming in general... Don't laugh at me when I ask, could you please elaborate a bit more on that?

And any other ideas, anyone?
Thanks!
 

ClimoC

Well-known Member
Joined
Aug 21, 2009
Messages
584
Thanks so much for the reply,
I'm honestly really new to VBA, and programming in general... Don't laugh at me when I ask, could you please elaborate a bit more on that?

And any other ideas, anyone?
Thanks!
Essentially the way the mouse works, and has always works, is that your movements are translated into pixel coordinates, like battleships, to tell Windows where the mouse pointer should be.

By tapping into the WinAPI32 Calls (At which point, you're WELL outside of the realms of even an advanced VB programmer), you can call on those coordinates.

I have an example code I downloaded from a super-expert whom years ago tried to get Drag'n'Drop to work on Cell values (By grabbing the 'White' of the Cell, rather than excel's Cut'n'Paste shortcut of grabbing the Selection's Border whent he mvoement arrows come up)

I've been programming for 6 years on a daily basis in VB - and this stuff is just mental hard and I wouldn't know where to begin. Stuff like:

Code:
Option Explicit


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


Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long


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


Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long


Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long


Private Declare Function CloseClipboard Lib "user32" () As Long


Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long


'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type


'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type


Private Type POINTAPI
x As Long
y As Long
End Type




Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const GWL_HINSTANCE = (-6)
'_______________________________________________________________


Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long


Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, _
ByVal wParam As Long, lParam As Any) As Long


Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long


Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDOWN = &H201


Private hhkLowLevelMouse As Long
Private blnHookEnabled As Boolean
Private udtCursorPos As POINTAPI


Private bButtonDown As Boolean
Private bFirstMouseMove As Boolean




Sub EnableDrag_Drop()
Sheets("Sheet1").Range("G1:H1").Interior.ColorIndex = 3
Sheets("Sheet1").Range("G1").Value = "Drag&Drop Mode is :  ON"
Sheets("Sheet1").Range("G1").Font.ColorIndex = 2
    Call Hook_Mouse


End Sub


Sub DisableDrag_Drop()
Sheets("Sheet1").Range("G1:H1").Interior.ColorIndex = 1
Sheets("Sheet1").Range("G1").Value = "Drag&Drop Mode is :  OFF"
Sheets("Sheet1").Range("G1").Font.ColorIndex = 2
    'reset cursor to normal
    Application.Cursor = xlDefault
    'reset the interactive prop here as safety net
    Application.Interactive = True
    ' remove hook
    Call UnHook_Mouse
    'refresh our range


    Application.CutCopyMode = False


End Sub


Private Sub Hook_Mouse()


    ' Prevent Hooking more than once
    If blnHookEnabled = False Then
        hhkLowLevelMouse = SetWindowsHookEx _
        (WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetAppInstance, 0)
        ' set flag
        blnHookEnabled = True
    End If


End Sub


Private Sub UnHook_Mouse()


    If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
    'reset Flag
    blnHookEnabled = False


End Sub


Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


    Static oCellToDrag As Range
    Static dPosX As Double
    Static dPosY As Double
    Static dOldPosX As Double
    Static dOldPosY As Double
    Static TopLeftCell As Range
    Static CellToDrag As Range
    Static oldRange As Range
    
    
    'Prevent crashing XL in case of unhandled errors !!!!!!!
    On Error Resume Next
        If (nCode = HC_ACTION) Then
        
        GetCursorPos udtCursorPos
        ' store the cell under the mouse pointer
        Set oCellToDrag = _
        ActiveWindow.RangeFromPoint(udtCursorPos.x, udtCursorPos.y)
        
        ' wParam holds the mouse current status
        Select Case wParam
        '**********************************************************
            Case Is = WM_LBUTTONDOWN
                'allow cell dragging in columns A:B only
                If Not IsCellWithinRange(oCellToDrag, Columns("a:b")) Then
                    Exit Function
                End If
                'set flag
                bFirstMouseMove = True
                ' set flag
                bButtonDown = True
                'store the cell being dragged in a static var
                Set CellToDrag = oCellToDrag
                ' as soon as the mouse left button is pressed
                ' take a snapshot of the cell under the mouse pointer
                ' and show the image control pop up
                ' this fires before the sheet selection event
                SaveRangePic oCellToDrag, "C:\MyRangePic.bmp"
                With Sheets("Sheet1").Image1
                    .Picture = LoadPicture("C:\MyRangePic.bmp")
                    .AutoSize = True
                    .Left = RangeUnderMouse.Left
                    .Top = RangeUnderMouse.Top
                    .Visible = False
                End With
                'cleanup file
                Kill "C:\MyRangePic.bmp"
            '**********************************************************
            Case Is = WM_LBUTTONUP
            ' reset flag
                bButtonDown = False
                ' avoid too much screen flickering
                Application.ScreenUpdating = False
                If Sheets("Sheet1").Image1.Visible Then
                    'are we dragging within columns A:B ?
                    If IsCellWithinRange(ByVal oCellToDrag, Columns("a:b")) And _
                    IsCellWithinRange(ByVal TopLeftCell, Columns("a:b")) Then
                        'if so, let's do the actual cells drag&drop here
                        TopLeftCell.Insert Shift:=xlDown
                        CellToDrag.Copy Destination:=TopLeftCell.Offset(-1)
                        'CellToDrag.Delete xlUp
                    Else
                        'if outside our dragging range stop and alert the user
                        Beep
                        Call UnHook_Mouse
                        MsgBox _
                        "Drag & Drop is only allowed between Columns A and B ! ", vbCritical
                        Call Hook_Mouse
                    End If
                End If
                'hide the image contrl until the next drag operation
                Sheets("Sheet1").Image1.Visible = False
            '**************************************************************
            Case Is = WM_MOUSEMOVE
                'block any interaction with XL while dragging the image contrl
                'over our drag&drop range to avoid unwanted selection of underlying cells
                If Union(oCellToDrag, Columns("a:b")).Address <> _
                Union(oldRange, Columns("a:b")).Address Then
                    If Not IsCellWithinRange(RangeUnderMouse, Columns("a:b")) Or _
                        RangeUnderMouse Is Nothing Then
                        Application.Cursor = xlDefault
                        Application.Interactive = True
                    Else
                        'restore cursor and user interactivity if mouse
                        'outside our Drag&Drop range
                        Application.Cursor = xlNorthwestArrow
                        Application.Interactive = False
                    End If
                End If
                'store cell being dragged
                Set oldRange = oCellToDrag
                ' convert pixels to points
                dPosX = udtCursorPos.x * 0.75
                dPosY = udtCursorPos.y * 0.75
                'see if the mouse is moving while the left button is held down
                'ie: see if dragging is underway
                If bButtonDown Then
                    If bFirstMouseMove Then
                        Sheets("Sheet1").Image1.Visible = True
                        'reset flag
                        bFirstMouseMove = False
                    End If
                    'now, adjust the pos of the image cntrl to follow
                    'the moving mouse pointer
                    With Sheets("Sheet1").Image1
                        .Left = (.Left) - (dOldPosX - dPosX)
                        .Top = (.Top) - (dOldPosY - dPosY)
                    End With
                    Set TopLeftCell = Sheets("Sheet1").Image1.TopLeftCell
                End If
                ' store previous mouse pos
                dOldPosX = dPosX
                dOldPosY = dPosY
        End Select
    End If
    'Call next hook if any
    LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)


End Function


Private Sub SaveRangePic(ByVal SourceRange As Range, FilePathName As String)


    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim hPtr As Long
    
    'Copy Range to ClipBoard
    SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    'Create the interface GUID for the picture
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    'Fill uPicInfo with necessary parts.
    With uPicinfo
        .Size = Len(uPicinfo) '\\ Length of structure.
        .Type = PICTYPE_BITMAP '\\ Type of Picture
        .hPic = hPtr '\\ Handle to image.
        .hPal = 0 '\\ Handle to palette (if bitmap).
    End With
    'Create the Range Picture Object
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    'Save Picture Object
    stdole.SavePicture IPic, FilePathName


End Sub


Private Function IsCellWithinRange(ByVal Cell As Range, Parent_Range As Range) As Boolean


    IsCellWithinRange = (Union(Cell, Parent_Range).Address = Parent_Range.Address)


End Function


Private Function RangeUnderMouse() As Range


    Dim udtP As POINTAPI
    
    On Error Resume Next
    GetCursorPos udtP
    Set RangeUnderMouse = ActiveWindow.RangeFromPoint(udtP.x, udtP.y)


End Function


Private Function GetAppHwnd() As Long


    'function needed for XL versions < 2000
    GetAppHwnd = FindWindow("XLMAIN", Application.Caption)


End Function


Private Function GetAppInstance() As Long


    'function needed for XL versions < 2000
    GetAppInstance = GetWindowLong(GetAppHwnd, GWL_HINSTANCE)


End Function
All I can say is 'Good Luck'. This code used to crash Excel after about 3 seconds of working.
 

Forum statistics

Threads
1,082,258
Messages
5,364,088
Members
400,779
Latest member
lumers

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top