Created
October 21, 2019 11:26
-
-
Save KotorinChunChun/718da75c26de71c9e4b12afa9c19ee32 to your computer and use it in GitHub Desktop.
Win32APIのDeclare文を自動的に64bit対応コードに変換するユーザーフォーム
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Rem VBA Declare宣言 64bit対応変換ツール | |
| Rem | |
| Rem 新規で作成したユーザーフォームのコードに貼り付けで使用する | |
| Rem | |
| Option Explicit | |
| Private Const GWL_STYLE = (-16) | |
| Private Const WS_THICKFRAME = &H40000 | |
| #If VBA7 Then | |
| #If Win64 Then | |
| Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr | |
| Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr | |
| #Else | |
| Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr | |
| Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr | |
| #End If | |
| #Else | |
| Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long | |
| Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long | |
| #End If | |
| #If VBA7 Then | |
| Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr | |
| #Else | |
| Private Declare Function GetActiveWindow Lib "user32" () As Long | |
| #End If | |
| #If VBA7 Then | |
| Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long | |
| #Else | |
| Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long | |
| #End If | |
| Private WithEvents TextBox1 As MSForms.TextBox | |
| Private WithEvents TextBox2 As MSForms.TextBox | |
| Private WithEvents Label1 As MSForms.Label | |
| Private WithEvents Label2 As MSForms.Label | |
| Private Sub UserForm_Initialize() | |
| Me.Caption = "VBA Declare宣言 64bit対応変換ツール" | |
| Set Label1 = Me.Controls.Add("Forms.Label.1", "Label1", True) | |
| Label1.Caption = "変換したいソース" | |
| Set Label2 = Me.Controls.Add("Forms.Label.1", "Label2", True) | |
| Label2.Caption = "変換されたソース" | |
| Set TextBox1 = Me.Controls.Add("Forms.TextBox.1", "TextBox1", True) | |
| TextBox1.EnterKeyBehavior = True | |
| TextBox1.MultiLine = True | |
| TextBox1.ScrollBars = fmScrollBarsBoth | |
| TextBox1.WordWrap = False | |
| Set TextBox2 = Me.Controls.Add("Forms.TextBox.1", "TextBox2", True) | |
| TextBox2.EnterKeyBehavior = True | |
| TextBox2.MultiLine = True | |
| TextBox2.ScrollBars = fmScrollBarsBoth | |
| TextBox2.WordWrap = False | |
| TextBox2.Locked = True | |
| TextBox2.BackColor = &H80000004 | |
| 'イベント発生につき最後に実行 | |
| Me.Width = 800 | |
| Me.Height = 600 | |
| End Sub | |
| Private Sub UserForm_Activate() | |
| Call FormSetting | |
| End Sub | |
| ' フォームをリサイズ可能にするための設定 | |
| Public Sub FormSetting() | |
| Dim result As LongPtr | |
| Dim hwnd As LongPtr | |
| Dim Wnd_STYLE As LongPtr | |
| hwnd = GetActiveWindow() | |
| Wnd_STYLE = GetWindowLongPtr(hwnd, GWL_STYLE) | |
| Wnd_STYLE = Wnd_STYLE Or WS_THICKFRAME Or &H30000 | |
| result = SetWindowLongPtr(hwnd, GWL_STYLE, Wnd_STYLE) | |
| result = DrawMenuBar(hwnd) | |
| End Sub | |
| Private Sub UserForm_Resize() | |
| If TextBox1 Is Nothing Then Exit Sub | |
| On Error Resume Next | |
| TextBox1.Left = 10 | |
| TextBox1.Top = 20 | |
| TextBox1.Width = Me.InsideWidth / 2 - 20 | |
| TextBox1.Height = Me.InsideHeight - 40 | |
| Label1.Left = TextBox1.Left | |
| Label1.Top = 5 | |
| TextBox2.Left = Me.InsideWidth / 2 + 10 | |
| TextBox2.Top = 20 | |
| TextBox2.Width = Me.InsideWidth / 2 - 20 | |
| TextBox2.Height = Me.InsideHeight - 40 | |
| Label2.Left = TextBox2.Left | |
| Label2.Top = 5 | |
| End Sub | |
| Private Sub TextBox1_Change() | |
| ' On Error Resume Next | |
| TextBox2.Text = ConvertVBACodeDeclare(TextBox1.Text, 10) | |
| ' On Error GoTo 0 | |
| End Sub |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Rem VBA Text 64bit対応Declare生成ツール | |
| Rem | |
| Rem 新規で作成したユーザーフォームのコードに貼り付けで使用する | |
| Rem | |
| Option Explicit | |
| Private Const GWL_STYLE = (-16) | |
| Private Const WS_THICKFRAME = &H40000 | |
| #If VBA7 Then | |
| #If Win64 Then | |
| Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr | |
| Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr | |
| #Else | |
| Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr | |
| Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr | |
| #End If | |
| #Else | |
| Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long | |
| Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long | |
| #End If | |
| #If VBA7 Then | |
| Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr | |
| #Else | |
| Private Declare Function GetActiveWindow Lib "user32" () As Long | |
| #End If | |
| #If VBA7 Then | |
| Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long | |
| #Else | |
| Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long | |
| #End If | |
| Private WithEvents TextBox1 As MSForms.TextBox | |
| Private WithEvents TextBox2 As MSForms.TextBox | |
| Private WithEvents Label1 As MSForms.Label | |
| Private WithEvents Label2 As MSForms.Label | |
| Private Sub UserForm_Initialize() | |
| Me.Caption = "VBA Text 64bit対応Declare生成ツール" | |
| Set Label1 = Me.Controls.Add("Forms.Label.1", "Label1", True) | |
| Label1.Caption = "変換したいソース" | |
| Set Label2 = Me.Controls.Add("Forms.Label.1", "Label2", True) | |
| Label2.Caption = "変換されたソース" | |
| Set TextBox1 = Me.Controls.Add("Forms.TextBox.1", "TextBox1", True) | |
| TextBox1.EnterKeyBehavior = True | |
| TextBox1.MultiLine = True | |
| TextBox1.ScrollBars = fmScrollBarsBoth | |
| TextBox1.WordWrap = False | |
| Set TextBox2 = Me.Controls.Add("Forms.TextBox.1", "TextBox2", True) | |
| TextBox2.EnterKeyBehavior = True | |
| TextBox2.MultiLine = True | |
| TextBox2.ScrollBars = fmScrollBarsBoth | |
| TextBox2.WordWrap = False | |
| TextBox2.Locked = True | |
| TextBox2.BackColor = &H80000004 | |
| 'イベント発生につき最後に実行 | |
| Me.Width = 800 | |
| Me.Height = 600 | |
| End Sub | |
| Private Sub UserForm_Activate() | |
| Call FormSetting | |
| End Sub | |
| ' フォームをリサイズ可能にするための設定 | |
| Public Sub FormSetting() | |
| Dim result As LongPtr | |
| Dim hwnd As LongPtr | |
| Dim Wnd_STYLE As LongPtr | |
| hwnd = GetActiveWindow() | |
| Wnd_STYLE = GetWindowLongPtr(hwnd, GWL_STYLE) | |
| Wnd_STYLE = Wnd_STYLE Or WS_THICKFRAME Or &H30000 | |
| result = SetWindowLongPtr(hwnd, GWL_STYLE, Wnd_STYLE) | |
| result = DrawMenuBar(hwnd) | |
| End Sub | |
| Private Sub UserForm_Resize() | |
| If TextBox1 Is Nothing Then Exit Sub | |
| On Error Resume Next | |
| TextBox1.Left = 10 | |
| TextBox1.Top = 20 | |
| TextBox1.Width = Me.InsideWidth / 2 - 20 | |
| TextBox1.Height = Me.InsideHeight - 40 | |
| Label1.Left = TextBox1.Left | |
| Label1.Top = 5 | |
| TextBox2.Left = Me.InsideWidth / 2 + 10 | |
| TextBox2.Top = 20 | |
| TextBox2.Width = Me.InsideWidth / 2 - 20 | |
| TextBox2.Height = Me.InsideHeight - 40 | |
| Label2.Left = TextBox2.Left | |
| Label2.Top = 5 | |
| End Sub | |
| Private Sub TextBox1_Change() | |
| ' On Error Resume Next | |
| TextBox2.Text = GetDeclareCodeByText(TextBox1.Text, True, True) | |
| ' On Error GoTo 0 | |
| End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment