GDIplusCODE


'☆UserForm1モジュール
'TextBox一個を置く。位置、寸法はコードで設定しているので適当で可

Private Declare Function SetWindowLong Lib "user32" _
  Alias "SetWindowLongA" _
  (ByVal hWnd As Long, ByVal nIndex As Long, _
  ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong Lib "user32" _
  Alias "GetWindowLongA" _
  (ByVal hWnd As Long, ByVal nIndex 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 SetWindowPos Lib "user32" _
  (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
  ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
  ByVal cy As Long, ByVal uFlags As Long) As Long

Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const GWL_STYLE = -16
Private Const GWL_EXSTYLE = -20
Private Const WS_CAPTION = &HC00000 'タイトルバーを持つウィンドウ
Private Const WS_SYSMENU = &H80000 'タイトルバー上にウィンドウメニューボックスを持つウィンドウ
Private Const WS_MINIMIZEBOX = &H20000 '最小化ボタンを持つウィンドウ
Private Const WS_MAXIMIZEBOX = &H10000 '最大化ボタンを持つウィンドウ
Private Const WS_EX_DLGMODALFRAME = &H1& '二重の境界線を持つウィンドウ
Private Const HWND_TOPMOST = -1& '常に手前に表示
Private Const HWND_TOP = 0 '手前に表示
Private Const SWP_FRAMECHANGED = &H20
Private Const DPI As Long = 96
Private Const PPI As Long = 72

Dim m_hwnd As Long
Dim R1C1Left As Long
Dim R1C1Top As Long

Private Sub UserForm_Initialize()
  With Me
    .StartUpPosition = 0
    .BorderStyle = fmBorderStyleNone
    .SpecialEffect = fmSpecialEffectFlat
    'フォームに時刻を名前としてつける
    .Caption = .Caption & Timer()
  End With
  '名前を手がかりとして、ユーザーフォームのハンドルを取得
  m_hwnd = FindWindow("ThunderDFrame", Me.Caption)
  ' フォームのメニュー、最大最小化ボタン等は一切表示しない設定とする
  SetWindowLong m_hwnd, GWL_STYLE, _
  GetWindowLong(m_hwnd, GWL_STYLE) And _
  Not (WS_SYSMENU Or WS_CAPTION Or _
  WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
  SetWindowLong m_hwnd, GWL_EXSTYLE, _
  GetWindowLong(m_hwnd, GWL_EXSTYLE) And _
  Not WS_EX_DLGMODALFRAME
  With Me.TextBox1
    .Top = 0
    .Left = 0
    .Height = Me.InsideHeight
    .Width = Me.InsideWidth
    .SpecialEffect = fmSpecialEffectFlat
    .BorderStyle = fmBorderStyleNone
    .Value = ActiveCell.Value
    .IMEMode = fmIMEModeOff
  End With
  
  R1C1Left = ActiveWindow.PointsToScreenPixelsX(0)
  R1C1Top = ActiveWindow.PointsToScreenPixelsY(0)
End Sub

Private Sub UserForm_Activate()
  Dim myLeft As Long, myTop As Long, myWidth As Long, myHeight As Long
  Dim zoomX As Single, zoomY As Single
  Const myFontSize = 11
  
  realZoomRate zoomX, zoomY
  myLeft = ((ActiveCell.Left * DPI / PPI) * zoomX) + R1C1Left
  myTop = ((ActiveCell.Top * DPI / PPI) * zoomY) + R1C1Top
  myWidth = zoomX * ActiveCell.Width * DPI / PPI
  myHeight = zoomY * ActiveCell.Height * DPI / PPI
  'フォームの表示順（Zオーダー）、サイズ指定
  SetWindowPos m_hwnd, HWND_TOP, myLeft, myTop, myWidth, myHeight, SWP_FRAMECHANGED
  Me.TextBox1.Font.Size = Int(myFontSize * zoomY)
  Me.TextBox1.Value = ActiveCell.Value
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Select Case KeyCode
    Case vbKeyReturn
      If IsNumeric(Me.TextBox1.Value) Then
        If CDbl(Me.TextBox1.Value) >= 1 Then
          If Left(Me.TextBox1.Value, 1) = "0" Then
          ActiveCell.Value = Format(Val(Me.TextBox1.Value), "#") & "K"
          '書式だけ KまたはC/S表示して、数値として残す場合。後々混乱するかも。
          'ActiveCell.Value = CDbl(Me.TextBox1.Value)
          'ActiveCell.NumberFormatLocal = "G/標準""K"""
          Else
          ActiveCell.Value = Me.TextBox1.Value & "C/S"
          'ActiveCell.Value = CDbl(Me.TextBox1.Value)
          'ActiveCell.NumberFormatLocal = "G/標準""C/S"""
          End If
        Else
          ActiveCell.Value = Me.TextBox1.Value
        End If
      Else
        'お好みで
        ActiveCell.Value = Me.TextBox1.Value
      End If
      ActiveCell.Offset(1, 0).Activate
      Unload Me
    Case vbKeyEscape
      Unload Me
  End Select
End Sub

 '真のズーム倍率を求める 'by kanabunさん
Private Sub realZoomRate(ByRef zoomX As Single, ByRef zoomY As Single)
  Dim c As Range
  Dim dotX As Long
  Dim dotY As Long
  Dim dotX1 As Long
  Dim dotY1 As Long
  
  Set c = Range("a1")
  With ActiveWindow
    ' ---------- 実際のZoom比の計算 ---------------
    dotY = c.Height * DPI / PPI
    dotY1 = dotY * .Zoom / 100
    zoomY = dotY1 / dotY '実際に適用されているZoom率
    dotX = c.Width * DPI / PPI
    dotX1 = dotX * .Zoom / 100
    zoomX = dotX1 / dotX
  End With
End Sub

'☆Sheet1モジュール
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim myForm As UserForm
  'とりえあずA列のみで動作する様にしてある
  If Target.Column <> 1 Then Exit Sub
  If Target.Cells.Count > 1 Then Exit Sub
  Dim f As UserForm
  'UserForm1が既に開いていれば閉じる
  For Each f In UserForms
    If TypeOf f Is UserForm1 Then Unload UserForm1
  Next
  UserForm1.Show
End Sub
セル編集中の文字を疑似制御する
