■UserForm.Imageのサイズ変更と移動

UserFormのImageコントロールに表示させている画像を自由に拡大/縮小表示させたい。
また、拡大表示の際、画像をドラッグさせる事で表示範囲を移動させたい。

...というような要求がもしあったら、Frameコントロール内にImageコントロールを配置し、Imageコントロールの拡大/縮小/移動で対応できます。

昨日前フリ (？：笑) したコードでサンプルフォームを作ってみましょう。
ついでにコードも .AddFromString してみます。

Option Explicit

Sub try()
　　Const vbext_ct_MSForm As Long = 3
　　Const fmPictureSizeModeZoom As Long = 3
　　Const mg As Single = 10
　　Const w　As Single = 200
　　Const h　As Single = 150
　　Dim iw　 As Single
　　Dim ih　 As Single
　　Dim i　　As Long
　　Dim v

　　With ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
　　　　With .Designer
　　　　　　With .Controls.Add("Forms.Frame.1")
　　　　　　　　.Left = mg
　　　　　　　　.Top = mg
　　　　　　　　.Width = w
　　　　　　　　.Height = h
　　　　　　　　With .Controls.Add("Forms.Image.1")
　　　　　　　　　　.Left = 0
　　　　　　　　　　.Top = 0
　　　　　　　　　　.Width = w
　　　　　　　　　　.Height = h
　　　　　　　　　　.PictureSizeMode = fmPictureSizeModeZoom
　　　　　　　　End With
　　　　　　End With
　　　　　　With .Controls.Add("Forms.CommandButton.1")
　　　　　　　　.Left = mg
　　　　　　　　.Top = mg * 2 + h
　　　　　　　　.Width = (w - mg) / 2
　　　　　　　　.Height = 20
　　　　　　　　.Caption = "Picture読み込み"
　　　　　　End With
　　　　　　With .Controls.Add("Forms.Scrollbar.1")
　　　　　　　　.Left = mg + (mg + w) / 2
　　　　　　　　.Top = mg * 2 + h
　　　　　　　　.Width = (w - mg) / 2
　　　　　　　　.Height = 20
　　　　　　　　.Min = 100
　　　　　　　　.Max = 200
　　　　　　　　.SmallChange = 1
　　　　　　　　.LargeChange = 10
　　　　　　End With
　　　　End With
　　　　iw = .Properties("Width") - .Properties("InsideWidth")
　　　　ih = .Properties("Height") - .Properties("InsideHeight")
　　　　.Properties("Width") = iw + mg * 2 + w
　　　　.Properties("Height") = ih + mg * 3 + h + 20
　　　　v = prctxt
　　　　For i = UBound(v) To LBound(v) Step -1
　　　　　　.CodeModule.AddFromString v(i)
　　　　Next
　　End With
End Sub
'---------------------------------------------------------------------
Function prctxt()
　　Dim s(1 To 7) As String

　　s(1) = "Private w　As Single" & vbLf _
　　　　 & "Private h　As Single" & vbLf _
　　　　 & "Private ix As Single" & vbLf _
　　　　 & "Private iy As Single"
　　s(2) = "Private Sub CommandButton1_Click()" & vbLf _
　　　　 & "　　Dim v" & vbLf _
　　　　 & "　　v = Application.GetOpenFilename(""jpgFile,*.jpg"")" & vbLf _
　　　　 & "　　If VarType(v) = vbBoolean Then Exit Sub" & vbLf _
　　　　 & "　　Me.Image1.Picture = LoadPicture(v)" & vbLf _
　　　　 & "　　Me.Repaint" & vbLf _
　　　　 & "End Sub"
　　s(3) = "Private Sub Image1_MouseDown(ByVal Button As Integer, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　　 ByVal Shift As Integer, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　　 ByVal x As Single, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　　 ByVal y As Single)" & vbLf _
　　　　 & "　　ix = x: iy = y" & vbLf _
　　　　 & "End Sub"
　　s(4) = "Private Sub Image1_MouseMove(ByVal Button As Integer, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　　 ByVal Shift As Integer, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　　 ByVal x As Single, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　　 ByVal y As Single)" & vbLf _
　　　　 & "　　If ix = 0 And iy = 0 Then Exit Sub" & vbLf _
　　　　 & "　　With Image1" & vbLf _
　　　　 & "　　　　.Left = .Left + x - ix" & vbLf _
　　　　 & "　　　　.Top = .Top + y - iy" & vbLf _
　　　　 & "　　End With" & vbLf _
　　　　 & "End Sub"
　　s(5) = "Private Sub Image1_MouseUp(ByVal Button As Integer, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　 ByVal Shift As Integer, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　 ByVal x As Single, _" & vbLf _
　　　　 & "　　　　　　　　　　　　　 ByVal y As Single)" & vbLf _
　　　　 & "　　ix = 0: iy = 0" & vbLf _
　　　　 & "End Sub"
　　s(6) = "Private Sub ScrollBar1_Change()" & vbLf _
　　　　 & "　　Dim z As Single" & vbLf _
　　　　 & "　　With Me" & vbLf _
　　　　 & "　　　　z = .ScrollBar1.Value / 100" & vbLf _
　　　　 & "　　　　With .Image1" & vbLf _
　　　　 & "　　　　　　.Width = w * z: .Height = h * z" & vbLf _
　　　　 & "　　　　　　If z = 1 Then" & vbLf _
　　　　 & "　　　　　　　　.Left = 1: .Top = 1" & vbLf _
　　　　 & "　　　　　　End If" & vbLf _
　　　　 & "　　　　End With" & vbLf _
　　　　 & "　　End With" & vbLf _
　　　　 & "End Sub"
　　s(7) = "Private Sub UserForm_Initialize()" & vbLf _
　　　　 & "　　With Me.Image1" & vbLf _
　　　　 & "　　　　w = .Width: h = .Height" & vbLf _
　　　　 & "　　End With" & vbLf _
　　　　 & "End Sub"
　　prctxt = s
End Function

▼のようなUserFormができます。...不具合が無ければ。



▼実行時のイメージ