Pan Image with click and drag

Someone on MSDN asked a question about clicking and draging an image to pan around while zoomed. The control already did the zoom and consists of a picturebox within a panel with autoscroll turned on. This would let you use the scrollbars to navigate, but the poster wanted to pan by dragging so here it is. I will add to it as needed but this seemed to work pretty well.


Public Class Form1
Dim x1, y1 As Double
Dim scrollSensitivity As Double
Dim md As Boolean
Private Sub PictureBox1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown
md = True
x1 = Me.Panel1.HorizontalScroll.Value
y1 = Me.Panel1.VerticalScroll.Value
End Sub
Private Sub PictureBox1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseMove
scrollSensitivity = 4
If md = True Then
Try
Me.Panel1.HorizontalScroll.Value = (e.X - x1) / scrollSensitivity
Me.Panel1.VerticalScroll.Value = (e.Y - y1) / scrollSensitivity
Catch ex As Exception
End Try
End If
End Sub
Private Sub PictureBox1_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseUp
md = False
End Sub
End Class


VBA: Copy x sheet from each file in folder

Sub CopySheet()
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Dim filePath As String
filePath = "C:\Documents and Settings\user\Desktop\Baskets\"
    Application.ScreenUpdating = False
    With Application.FileSearch
        .NewSearch
        .LookIn = filePath
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            Set basebook = ThisWorkbook
            For i = 1 To .FoundFiles.Count
                Set mybook = Workbooks.Open(.FoundFiles(i))
                    mybook.Worksheets("What Sells With My Item").Copy after:= _
                    basebook.Sheets(1)
                    ActiveSheet.Name = Mid(mybook.Name, 1, Len(mybook.Name) - 4)
               mybook.Close
        
           Next i
       End If
     
    End With
    Application.ScreenUpdating = True
End Sub

VBA: Random Letter generator

Private Sub MakeRandom()
Dim theNum As Double
Dim theUpper As String
Dim theLower As String

' Upper Case
theUpper = Chr(64 + Rnd() * 10000000 Mod 26)
' Lower Case
theLower = Chr(96 + Rnd() * 10000000 Mod 26)

End Sub

VBA: Manipulate registry *MAKE A BACKUP FIRST*

*Not responsible for those who mess up and didn't backup.

        Dim pRegKey As RegistryKey = Registry.CurrentUser
        pRegKey = pRegKey.OpenSubKey("Software\\Microsoft\\Internet Explorer\Main", True)
        'Dim val As Object = pRegKey.GetValue("Display Inline Images")
        pRegKey.SetValue("Display Inline Images", "no")

VBA: Extract all data from a closed workbook

Dim ConString As String
Dim strSQL    As String
Dim DBPATH    As String
Dim recordset As New ADODB.recordset

DBPATH = ThisWorkbook.Path & "\Data.xls"

ConString = "Provider=Microsoft.jet.oledb.4.0;" & _
                   "Data Source=" & DBPATH & ";" & _
                   "extended Properties=Excel 8.0;"

strSQL = "SELECT * FROM [Data$]"

Set recordset = New ADODB.recordset

On Error GoTo cleanup:

Call recordset.Open(strSQL, ConString, adOpenForwardOnly, adLockReadOnly,
CommandTypeEnum.adCmdText)

Call Sheets("DataDump").Range("A2").CopyFromRecordset(recordset)

Set recordset = Nothing

VBA: Find all files in folder by extension

Sub findBSAfiles()
 Dim objFSO    As Object
Dim objFolder As Object
Dim objFile   As Object
Dim strPath   As String
Dim strName   As String 
' Specify the folder...  
strPath = "pathname"
' Use Microsoft Scripting runtime.  
Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set objFolder = objFSO.GetFolder(strPath)   
' Check extension of each file in folder.  
For Each objFile In objFolder.Files    
If Right(objFile.Name, 4) = ".xls" Then
strName = strName & "**" & objFile.Name & "**" & vbCrLf  
End If
Next objFile ' Display file names in message box. 
MsgBox strName  
Set objFSO = Nothing  
Set objFolder = Nothing  
Set objFile = Nothing
End Sub

VBA: Remove buttons by name

'If the forms menu, use
Sub RemoveButtons()     
Dim ShapeA As Button     
For Each ShapeA In ActiveSheet.Buttons           
If ShapeA.Caption = "Doodle" Then ShapeA.Delete     
Next ShapeA
End Sub

'If from the control toolbox, use
Sub RemoveButtons()     
Dim ShapeA As OLEObject     
For Each ShapeA In ActiveSheet.OLEObjects           
If ShapeA.Object.Caption = "Doodle" Then ShapeA.Delete     
Next ShapeA
End Sub