Skip to content

Instantly share code, notes, and snippets.

@baoo777

baoo777/VBA

Created January 24, 2018 18:49
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save baoo777/1759063b5e90cc33a157592ab9b6adae to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save baoo777/1759063b5e90cc33a157592ab9b6adae to your computer and use it in GitHub Desktop.
Download ZIP
TextWindow
Raw
VBA
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function SendMessageB Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type WNDCLASSEX
cbSize As Long
style As Long
lpfnWndProc As Long
cbClsExtra As Long
cbWndExtra As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
hIconSm As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Type LOGPEN
lopnStyle As Long
lopnWidth As POINTAPI
lopnColor As Long
End Type
Private Type PAINTSTRUCT
hDC As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved As Byte
End Type
Private Const HWND_TOP = 0
Private Const PS_SOLID = 0
Private Const PS_DASH = 1
Private Const PS_DOT = 2
Private Const PS_DASHDOT = 3
Private Const PS_DASHDOTDOT = 4
Private Const PS_NULL = 5
Private Const SRCCOPY = &HCC0020
Private G_hDC As Long
Private Const CS_VREDRAW As Long = &H1
Private Const CS_HREDRAW As Long = &H2
Private Const IDI_APPLICATION As Long = 32512
Private Const IDC_ARROW As Long = 32512
Private Const WHITE_BRUSH As Long = 0
Private Const WS_OVERLAPPED As Long = &H0
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_EX_APPWINDOW As Long = &H40000
Private Const WS_OVERLAPPEDWINDOW As Long = (WS_OVERLAPPED Or _
WS_CAPTION Or _
WS_SYSMENU Or _
WS_THICKFRAME Or _
WS_MINIMIZEBOX Or _
WS_MAXIMIZEBOX)
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const WS_EX_TOOLWINDOW = &H80
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_POPUP = &H80000000
Private Const WS_EX_LAYERED = &H80000 '拡張ウィンドウ属
Private Const WS_EX_TRANSPARENT = &H20
Private Const WS_EX_WINDOWEDGE = &H100
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_VSCROLL = &H100000
Private Const WS_HSCROLL = &H200000
Private Const CCS_BOTTOM = &H3
Private Const SB_SETPARTS = &H404
Private Const SB_SETTEXT = &H401
Private Const SB_SIMPLEID = &HFF
Private Const SBARS_SIZEGRIP = &H100
Private Const BS_PUSHBUTTON = &H0&
Private Const BS_AUTOCHECKBOX = &H3
Private Const BS_AUTORADIOBUTTON = &H9
Private Const BS_GROUPBOX = &H7
Private Const ES_LEFT As Long = &H0
Private Const EN_UPDATE As Long = &H400
Private Const EN_VSCROLL = &H602
Private Const EN_HSCROLL = &H601
Private Const ES_AUTOHSCROLL As Long = &H80 '水平方向自動スクロール
Private Const ES_AUTOVSCROLL As Long = &H40
Private Const EM_GETSEL = &HB0
Private Const ES_MULTILINE = &H4
Private Const EM_REPLACESEL = &HC2
Private Const CW_USEDEFAULT As Long = &H80000000
Private Const SW_SHOW As Long = 5
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_DESTROY As Long = &H2
Private Const WM_PAINT As Long = &HF
Private Const WM_CREATE As Long = &H1
Private Const WM_COMMAND As Long = &H111
Private Const WM_MENUSELECT = &H11F
Private Const WM_NOTIFY As Long = &H4E
Private Const WM_HSCROLL As Long = &H114
Private Const WM_VSCROLL As Long = &H115
Private Const WM_SIZE = &H5
Private Const WM_GETTEXT = &HD
Private Const WM_SETTEXT = &HC
Private Const WM_SETFONT = &H30
Private Const WM_GETFONT = &H31
Private Const WM_KEYDOWN = &H100
Private Const APP_NAME As String = "HELLOAPP"
Public APP_TITLE As String
Private Const CREATE_WINDOW_WIDTH = 800
Private Const CREATE_WINDOW_HEIGHT = 300
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20) '拡張ウィンドウスタイル
Private Const LWA_COLORKEY = 1 'crKeyを透明色として使う
Private Const LWA_ALPHA = 2 'bAlphaをアルファー値として使う
Private Const SWP_NOSIZE = &H1&
Private Const SWP_NOMOVE = &H2&
Private Const SWP_NOZORDER = &H4&
Private Const SWP_FRAMECHANGED = &H20&
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Declare Function SetLayeredWindowAttributes Lib "USER32.DLL" _
(ByVal hwnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Long, _
ByVal dwFlags As Long) As Long
'Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
' (ByVal lpClassName As String, _
' ByVal lpWindowName As String) As Long
'Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" _
' (ByVal hWndParent As Long, _
' ByVal hwndChildAfter As Long, _
' ByVal lpszClass As String, _
' ByVal lpszWindow As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As Long) As Long
Private Declare Function LoadIcon Lib "user32" Alias "LoadIconA" _
(ByVal hInstance As Long, _
ByVal lpIconName As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" _
(ByVal hInstance As Long, _
ByVal lpCursorName As Long) As Long
Private Declare Function GetStockObject Lib "GDI32" _
(ByVal fnObject As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" _
(lpwcx As WNDCLASSEX) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" _
(ByVal lpClassName As String, _
ByVal hInstance As Long) As Long
Private Declare Function AdjustWindowRectEx Lib "USER32.DLL" _
(lpRect As RECT, _
ByVal dwStyle As Long, _
ByVal bMenu As Long, _
ByVal dwExStyle As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hwndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function UpdateWindow Lib "user32" _
(ByVal lhwnd As Long) As Long
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" _
(lpMsg As MSG, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32" _
(lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" _
(lpMsg As MSG) As Long
Private Declare Sub PostQuitMessage Lib "user32" _
(ByVal nExitCode As Long)
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function Bitblt Lib "GDI32" Alias "BitBlt" _
(ByVal hdcDest As Long, _
ByVal nDX As Long, _
ByVal nDY As Long, _
ByVal nDW As Long, _
ByVal nDH As Long, _
ByVal hdcSrc As Long, _
ByVal nSX As Long, _
ByVal nSY As Long, _
ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" _
(ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal nW As Long, _
ByVal nH As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function GetObject Lib "GDI32" Alias "GetObjectA" _
(ByVal hObject As Long, _
ByVal nCount As Long, _
lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" _
(ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" _
(ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "gdi32.dll" _
(ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function SetBkColor Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" _
(ByVal hDC As Long, _
ByRef r As RECT, _
ByVal hBrush As Long) As Long
Private Declare Function CreatePenIndirect Lib "gdi32.dll" _
(lpLogPen As LOGPEN) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal pLastPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal XEnd As Long, _
ByVal YEnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SetWindowLong Lib "USER32.DLL" Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowPos Lib "USER32.DLL" _
(ByVal hwnd As Long, _
ByVal hWndInertAfter 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 Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Declare Function BeginPaint Lib "user32" _
(ByVal hwnd As Long, _
lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" _
(ByVal hwnd As Long, _
lpPaint As PAINTSTRUCT) As Long
Private Declare Function Chord Lib "GDI32" _
(ByVal hDC As Long, _
ByVal nLeftRect As Long, _
ByVal nTopRect As Long, _
ByVal nRightRect As Long, _
ByVal nBottomRect As Long, _
ByVal nXRadial1 As Long, _
ByVal nYRadial1 As Long, _
ByVal nXRadial2 As Long, _
ByVal nYRadial2 As Long) As Long
Private Declare Function Ellipse Lib "GDI32" _
(ByVal hDC As Long, _
ByVal nLeftRect As Long, _
ByVal nTopRect As Long, _
ByVal nRightRect As Long, _
ByVal nBottomRect As Long) As Long
Private Declare Function CreateSolidBrush Lib "GDI32" _
(ByVal crColor As Long) As Long
Private Declare Function Rectangle Lib "GDI32" _
(ByVal hDC As Long, _
ByVal nLeftRect As Long, _
ByVal nTopRect As Long, _
ByVal nRightRect As Long, _
ByVal nBottomRect As Long) As Long
Private Declare Sub InitCommonControls Lib "Comctl32.dll" ()
'=======================
' ファイルを開くダイアログボックス
'=======================
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As Long
'=============================
' [ファイル名を付けて保存] ダイアログボックス
'=============================
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (lpofn As OPENFILENAME) As Long
'===============
' OPENFILENAME構造体
'===============
Private Type OPENFILENAME
lStructSize As Long '構造体のサイズ
hwndOwner As Long 'ウインドウのハンドル
hInstance As Long 'インスタンスハンドル
lpstrFilter As String 'フィルタ
lpstrCustomFilter As String 'カスタムフィルタ
nMaxCustFilter As Long 'カスタムフィルタのサイズ
nFilterIndex As Long 'フィルタのインデックス
lpstrFile As String 'ファイル名のバッファ
nMaxFile As Long 'ファイル名のバッファのサイズ
lpstrFileTitle As String 'フルパス用のバッファ
nMaxFileTitle As Long 'フルパス用のバッファのサイズ
lpstrInitialDir As String 'ディレクトリを指定
lpstrTitle As String 'ダイヤログボックスのタイトル
flags As Long '定数（OFN＿××参照）
nFileOffset As Integer 'フルパスの中のファイル名までのオフセット
nFileExtension As Integer '拡張子までのオフセット
lpstrDefExt As String 'デフォルトの拡張子
lCustData As Long 'lpfnHookで渡すデータ
lpfnHook As Long 'フック関数のポインタ
lpTemplateName As String 'テンプレート名
End Type
Private Const OFN_ALLOWMULTISELECT = &H200 '複数ファイルを選択可能にする
Private Const OFN_CREATEPROMPT = &H2000 '指定のファイル名が存在しない時にメッセージボックスを表示
Private Const OFN_FILEMUSTEXIST = &H1000 '存在しないファイル名は入力不可
Private Const OFN_HIDEREADONLY = &H4 '読み取り専用のチェックボックスを非表示
Private Const OFN_NOCHANGEDIR = &H8 '他のサブディレクトリから選択不可
Private Const OFN_NOREADONLYRETURN = &H8000 '読み込み専用ファイルと書きこみ禁止ディレクトリの選択不可
Private Const OFN_NOVALIDATE = &H100 'ファイル名の有効性をチェックしない
Private Const OFN_OVERWRITEPROMPT = &H2 '既存のファイル名を指定した時にメッセージを出す
Private Const OFN_PATHMUSTEXIST = &H800 '有効なパスだけをうけつける
Private Const OFN_READONLY = &H1 '読み取り専用のチェックボックスをチェック
Private Const OFN_SHOWHELP = &H10 'ヘルプボタンを表示
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Private Declare Function CreateMenu Lib "user32" () As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" _
(ByVal hMenu As Long, _
ByVal wFlags As Long, _
ByVal wIDNewItem As Long, _
ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" _
(ByVal hMenu As Long) As Long
Private Declare Function SetMenu Lib "user32" _
(ByVal hwnd As Long, _
ByVal hMenu As Long) As Long
'Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" _
' (ByVal hMenu As Long, _
' ByVal un As Long, _
' ByVal bool As Boolean, _
' lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenu Lib "user32" _
(ByVal hMenu As Long, _
ByVal wFlags As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nReserved As Long, _
ByVal hwnd As Long, _
lprc As RECT) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" _
(ByVal hMenu As Long, _
ByVal un As Long, _
ByVal b As Long, _
lpMenuItemInfo As MENUITEMINFO) As Long
Private Const MF_ENABLED = 0
Private Const ID_TEST1 = 1
Private Const ID_TEST2 = 2
Private Const ID_TEST3 = 3
Private Const ID_TEST4 = 4
Private Const MF_POPUP = &H10&
Public hPracBtn As Long
Public hPracBtn2 As Long
Public hPracTxt As Long
Public hPracStatus As Long
Public hPracDate As Long
Public hPracTrack As Long
Private strTmp() As String
Private Declare Function CreateFontIndirect Lib "GDI32" Alias "CreateFontIndirectW" _
(lpLogFont As Long) As Long
Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
'lfFaceName(LF_FACESIZE) As Byte
lfFaceName As String * 32
End Type
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColor As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
iAlign As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" _
(pChoosefont As CHOOSEFONT) As Long
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" _
(pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function SetTextColor Lib "GDI32" _
(ByVal hDC As Long, _
ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "GDI32" Alias "TextOutA" _
(ByVal hDC As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, _
hpvSource As Any, _
ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
'Private Const FW_NORMAL = 400
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_ROMAN = 16
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_EFFECTS = &H100
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_INITTOLOGFONTSTRUCT = &H40
Private Const CF_LIMITSIZE = &H2000&
Private Const REGULAR_FONTTYPE = &H400
Private Declare Sub GetLocalTime Lib "KERNEL32.dll" _
(t As SYSTEMTIME)
Private Declare Function GetTimeFormat Lib "kernel32" Alias "GetTimeFormatA" _
(ByVal Locale As Long, _
ByVal dwFlags As Long, _
lpTime As SYSTEMTIME, _
ByVal lpFormat As Any, _
ByVal lpTimeStr As String, _
ByVal cchTime As Long) As Long
Private Const LOCALE_SYSTEM_DEFAULT = 2048
Private Const LOCALE_NOUSEROVERRIDE = &H80000000
Private Const WM_USER = &H400
Private Const DATETIMEPICK_CLASS = "SysDateTimePick32"
Private Const ICC_DATE_CLASSES = &H100&
Private Const DTS_UPDOWN = &H1
Private Const DTS_SHOWNONE = &H2
Private Const DTS_SHORTDATEFORMAT = &H0
Private Const DTS_LONGDATEFORMAT = &H4
Private Const DTS_TIMEFORMAT = &H9
Private Const DTS_APPCANPARSE = &H10
Private Const DTS_RIGHTALIGN = &H20
Private Const DTM_GETSYSTEMTIME = &H1001&
Private Const DTM_SETSYSTEMTIME = &H1002&
Private Const DTM_SETFORMAT = &H1005&
Private Const DTN_FIRST = -740
Private Const DTN_FIRST2 = -753
Private Const DTN_DATETIMECHANGE = DTN_FIRST2 - 6
Private Const DTN_USERSTRING = DTN_FIRST2 - 5
Private Const DTN_WMKEYDOWN = DTN_FIRST2 - 4
Private Const DTN_FORMAT = DTN_FIRST2 - 3
Private Const DTN_FORMATQUERY = DTN_FIRST2 - 2
Private Const DTN_DROPDOWN = DTN_FIRST2 - 1
Private Const DTN_CLOSEUP = DTN_FIRST2 - 0
Private Const DTN_USERSTRINGW = DTN_FIRST - 5
Private Const DTN_WMKEYDOWNW = DTN_FIRST - 4
Private Const DTN_FORMATW = DTN_FIRST - 3
Private Const DTN_FORMATQUERYW = DTN_FIRST - 2
Private Type NMHDR
hwndFrom As Long
idFrom As Long
code As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type NMDATETIMECHANGE
tNMHDR As NMHDR
dwFlags As Long
tSYSTEMTIME As SYSTEMTIME
End Type
Private Const TBS_AUTOTICKS = &H1 'チックマーク（目盛）を自動的に表示する
Private Const TBS_VERT = &H2 '垂直トラックバー
Private Const TBS_HORZ = &H0 '水平トラックバー（デフォルト）
Private Const TBS_TOP = &H4 'チックマークを上側に表示
Private Const TBS_BOTTOM = &H0 'チックマークを下側に表示(デフォルト）
Private Const TBS_LEFT = &H4 'チックマークを左側に表示
Private Const TBS_RIGHT = &H0 'チックマークを右側に表示（デフォルト）
Private Const TBS_BOTH = &H8 'チックマークを両側に表示
Private Const TBS_NOTICKS = &H10 'チックマークなし
Private Const TBS_ENABLESELRANGE = &H20 '範囲選択を可能にする
Private Const TBS_FIXEDLENGTH = &H40 'スライダーの長さを可変にできる
Private Const TBS_NOTHUMB = &H80 'つまみなし
Private Const TBM_GETPOS = WM_USER 'スライダーの位置を取得
Private Const TBM_GETRANGEMIN = WM_USER + 1 'スライダーの位置の最小位置の取得
Private Const TBM_GETRANGEMAX = WM_USER + 2 'スライダーの位置の最大位置の取得
Private Const TBM_GETTIC = WM_USER + 3 '特定のチックマークの位置を取得
Private Const TBM_SETTIC = WM_USER + 4 '特定のチックマークの位置を設定
Private Const TBM_SETPOS = WM_USER + 5 'スライダーの位置を設定
Private Const TBM_SETRANGE = WM_USER + 6 'スライダー位置の可変範囲の設定
Private Const TBM_SETRANGEMIN = WM_USER + 7 'スライダー位置の可変範囲の最小値の設定
Private Const TBM_SETRANGEMAX = WM_USER + 8 'スライダー位置の可変範囲の最大値の設定
Private Const TBM_CLEARTICS = WM_USER + 9 '現在のチックマークを削除
Private Const TBM_SETSEL = WM_USER + 10 'チックマークの選択範囲の設定
Private Const TBM_SETSELSTART = WM_USER + 11 'チックマークの選択範囲の終了値の設定
Private Const TBM_SETSELEND = WM_USER + 12 'チックマークの選択範囲の開始値の設定
Private Const TBM_GETPTICS = WM_USER + 14 'チックマーク位置を示す配列を指すポインタの取得
Private Const TBM_GETTICPOS = WM_USER + 15 'チックマークの物理位置の取得
Private Const TBM_GETNUMTICS = WM_USER + 16 'チックマークの数の取得
Private Const TBM_GETSELSTART = WM_USER + 17 '選択範囲の開始位置の取得
Private Const TBM_GETSELEND = WM_USER + 18 '選択範囲の終了位置の取得
Private Const TBM_CLEARSEL = WM_USER + 19 '選択範囲の解除
Private Const TBM_SETTICFREQ = WM_USER + 20 'チックマークの間隔の設定
Private Const TBM_SETPAGESIZE = WM_USER + 21 'ページサイズの設定
Private Const TBM_GETPAGESIZE = WM_USER + 22 'ページサイズの取得
Private Const TBM_SETLINESIZE = WM_USER + 23 'ラインサイズの設定
Private Const TBM_GETLINESIZE = WM_USER + 24 'ラインサイズの取得
Private Const TBM_GETTHUMBRECT = WM_USER + 25 'つまみの境界矩形の取得
Private Const TBM_GETCHANNELRECT = WM_USER + 26 'スライダーが動くチャンネルの境界矩形の取得
Private Const TBM_SETTHUMBLENGTH = WM_USER + 27 'つまみの長さの設定
Private Const TBM_GETTHUMBLENGTH = WM_USER + 28 'つまみの長さの取得
Private Const SB_PAGEDOWN = &H3
Private Const SB_PAGEUP = &H2
Private Const SB_LINEUP = &H0
Private Const SB_LINEDOWN = &H1
Private Const SB_BOTTOM = &H7
Private Const SB_TOP = &H6
Private Const SB_THUMBPOSITION = &H4
Private Const SB_THUMBTRACK = &H5
'=============TEMP=================
'システムパラメータ情報の取得API
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
ByRef lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Private Const SPI_GETWORKAREA = 48
Public Sub ImportText()
Dim Ret As Long
Ret = CreateGraph(7, 29, 720, 853)
Debug.Print Ret
End Sub
' /////////////////////////////////////////////////////////////////////////////////////
' //#名称 CreateGraph
' //
' //#概要 スケジュールシートのShapeオブジェクトから呼び出される。
' //
' //#引数
' //
' //#戻値
' //
' //#解説 集計結果シートから情報を取得し、進捗率をカテゴリごとに表示する
' //
' //#履歴 2011/04/12
' // Coded by YASUTADA OOBA
' //
' /////////////////////////////////////////////////////////////////////////////////////
Public Function CreateGraph(lngLeft As Long, lngTop As Long, lngRight As Long, lngBottom As Long) As Long
Dim hwnd As Long
Dim dwStyle As Long
Dim dwStyleEx As Long
Dim wc As WNDCLASSEX
Dim message As MSG
Dim Ret As Long
Dim tmpRECT As RECT
Dim rcRect As RECT
Dim lpPaint As PAINTSTRUCT
Dim mWS As Long
wc.cbSize = Len(wc)
wc.style = CS_HREDRAW Or CS_VREDRAW
wc.lpfnWndProc = FPtr(AddressOf WindowProc)
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = GetModuleHandle(0)
wc.hbrBackground = GetStockObject(WHITE_BRUSH)
wc.lpszMenuName = vbNullString
wc.lpszClassName = APP_NAME
If RegisterClassEx(wc) = 0 Then
'UnregisterClass wc.lpszClassName, wc.hInstance
Exit Function
End If
Ret = GetDesktopWindow()
Ret = GetWindowRect(Ret, tmpRECT)
rcRect.Left = lngLeft
rcRect.Top = lngTop
rcRect.Right = lngRight
rcRect.Bottom = lngBottom
dwStyleEx = WS_EX_WINDOWEDGE Or WS_EX_TOOLWINDOW
dwStyle = WS_CLIPSIBLINGS Or WS_OVERLAPPEDWINDOW
Ret = AdjustWindowRectEx(rcRect, dwStyle, False, dwStyleEx)
hwnd = CreateWindowEx(dwStyleEx, _
APP_NAME, _
APP_TITLE, _
dwStyle, _
rcRect.Left, _
rcRect.Top, _
rcRect.Right - rcRect.Left, _
rcRect.Bottom - rcRect.Top, _
0, _
0, _
wc.hInstance, _
0)
Dim hMenu As Long
Dim hPop As Long
Dim blAppend As Boolean
Dim i As Long
hMenu = CreateMenu()
hPop = CreatePopupMenu()
blAppend = AppendMenu(hMenu, MF_POPUP, hPop, "ファイル(&F)")
blAppend = AppendMenu(hPop, MF_ENABLED, 1, "開く")
strTmp = GetTmpTxt()
If Sgn(strTmp) <> 0 Then
For i = 0 To UBound(strTmp)
blAppend = AppendMenu(hPop, MF_ENABLED, i + 3, strTmp(i))
Next i
End If
blAppend = AppendMenu(hPop, MF_ENABLED, 2, "終了")
Dim hPop2 As Long
hPop2 = CreatePopupMenu()
blAppend = AppendMenu(hMenu, MF_POPUP, hPop2, "編集(&E)")
blAppend = AppendMenu(hPop2, MF_ENABLED, 10, "フォント")
blAppend = AppendMenu(hPop2, MF_ENABLED, 11, "色")
blAppend = SetMenu(hwnd, hMenu)
Call ShowWindow(hwnd, SW_SHOW)
Call UpdateWindow(hwnd)
Do While (GetMessage(message, 0, 0, 0))
Call TranslateMessage(message)
Call DispatchMessage(message)
Loop
Application.Visible = True
UnregisterClass wc.lpszClassName, wc.hInstance
CreateGraph = hwnd
End Function
' /////////////////////////////////////////////////////////////////////////////////////
' //#名称 WindowProc
' //
' //#概要 GraphウィンドウのWindowプロシージャ。
' //
' //#引数
' //
' //#戻値
' //
' //#解説
' //
' //#履歴 2011/04/12
' // Coded by YASUTADA OOBA
' //
' /////////////////////////////////////////////////////////////////////////////////////
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hDC As Long
Dim lpPaint As PAINTSTRUCT
Dim strctRECT As RECT
Dim lngRet As Long
Dim tmpRECT As RECT
Dim strBuff As String
Dim lngLen As Long
Dim Ret As Long
Dim mWS As Long
Dim lngSt As Long
Dim lngEd As Long
Dim FName As String
Dim strFilter As String
Dim strRep As String
Select Case uMsg
Case WM_CREATE
Call InitCommonControls
' 'InsertButton
' mWS = WS_CHILD Or WS_VISIBLE Or BS_PUSHBUTTON
' hPracBtn = CreateWindowEx(0, "Button", "Btn1", mWS, 20, 750, 100, 40, hWnd, 0, 0, 0)
'
' 'TestButton
' mWS = WS_CHILD Or WS_VISIBLE Or BS_PUSHBUTTON
' hPracBtn2 = CreateWindowEx(0, "Button", "Btn1", mWS, 140, 750, 100, 40, hWnd, 0, 0, 0)
'Edit
mWS = WS_CHILD Or WS_VISIBLE Or ES_LEFT Or ES_AUTOHSCROLL Or ES_AUTOVSCROLL Or ES_MULTILINE Or WS_HSCROLL Or WS_VSCROLL
hPracTxt = CreateWindowEx(WS_EX_CLIENTEDGE, "EDIT", "Text1", mWS, 0, 0, 713, 730, hwnd, 0, 0, 0)
'StatusBar
mWS = WS_CHILD Or WS_VISIBLE Or CCS_BOTTOM Or SBARS_SIZEGRIP
hPracStatus = CreateWindowEx(0, "msctls_statusbar32", "hoge", mWS, 0, 0, 0, 0, hwnd, 0, 0, 0)
'DateTime
mWS = WS_CHILD Or WS_VISIBLE
hPracDate = CreateWindowEx(0, "SysDateTimePick32", "Date1", mWS, 20, 730, 100, 30, hwnd, 0, 0, 0)
mWS = WS_CHILD Or WS_VISIBLE Or TBS_AUTOTICK
hPracTrack = CreateWindowEx(0, "msctls_trackbar32", "TrackBar", mWS, 200, 730, 100, 30, hwnd, 0, 0, 0)
Dim strStatus As String
Dim aryP(2) As Long
aryP(0) = 100
aryP(1) = 150
aryP(2) = 200
strStatus = StrConv("hoge", vbFromUnicode)
Debug.Print "Status" & hPracStatus
lngRet = SendMessage(hPracStatus, SB_SETPARTS, 3, aryP(0))
lngRet = SendMessage(hPracStatus, SB_SETTEXT, 0, ByVal StrPtr(strStatus))
lngRet = SendMessage(hPracTrack, TBM_SETRANGEMIN, 1, ByVal 0)
lngRet = SendMessage(hPracTrack, TBM_SETRANGEMAX, 1, ByVal 5)
' lngRet = SendMessage(hPracTrack, TBM_SETSELSTART, 1, ByVal 0)
' lngRet = SendMessage(hPracTrack, TBM_SETSELEND, 1, ByVal 100)
lngRet = SendMessage(hPracTrack, TBM_SETTICFREQ, 5, 0)
lngRet = SendMessage(hPracTrack, TBM_SETPOS, False, 50)
lngRet = SendMessage(hPracTrack, TBM_GETRANGEMIN, 0, 0)
Debug.Print "MIN" & lngRet
lngRet = SendMessage(hPracTrack, TBM_GETRANGEMAX, 0, 0)
Debug.Print "MAX" & lngRet
Case WM_SIZE
lngRet = MoveWindow(hPracTxt, 0, 0, LoWord(lParam), HiWord(lParam) - 94, 0)
lngRet = SendMessage(hPracStatus, WM_SIZE, wParam, lParam)
WindowProc = 0
Case WM_DESTROY
Call PostQuitMessage(0)
WindowProc = 0
Case WM_COMMAND
Debug.Print "lParam" & lParam
Debug.Print "HiWord(wParam)" & HiWord(wParam)
Debug.Print "LoWord(wParam)" & LoWord(wParam)
' If lParam = hPracBtn Then
' strBuff = String(255, vbNullChar)
' lngRet = SendMessageB(hPracTxt, WM_GETTEXT, Len(strBuff), StrPtr(strBuff))
' strBuff = StrConv(strBuff, vbUnicode)
' lngRet = SendMessage(hPracTxt, EM_GETSEL, VarPtr(lngSt), lngEd)
' If lngEd > lngSt And strBuff <> "" Then
' InsertComment Mid(strBuff, lngSt + 1, lngEd - lngSt)
' lngRet = SendMessage(hPracTxt, EM_REPLACESEL, 0, StrPtr(strRep))
' End If
'
' ElseIf lParam = hPracBtn2 Then
'' strFilter = "すべてのファイル(*.*)" & Chr(0) & "*.*" & Chr(0)
'' FName = apiGetOpenFileName(hwnd, strFilter, "C:\Users\" & Environ("USERNAME") & "\Desktop")
'' If FName <> "" Then
'' OpenText hPracTxt, FName
'' End If
' Dim lfont As LOGFONT
' Dim hFont As Long
' lfont = OpenChooseFont(hPracTxt)
' hFont = CreateFontIndirect(ByVal VarPtr(lfont))
' lngRet = SendMessage(hPracTxt, WM_SETFONT, hFont, 1)
'
' ElseIf lParam = 0 And HiWord(wParam) = 0 And LoWord(wParam) <> 0 Then
If lParam = 0 And HiWord(wParam) = 0 And LoWord(wParam) <> 0 Then
Select Case LoWord(wParam)
Case 1
strFilter = "すべてのファイル(*.*)" & Chr(0) & "*.*" & Chr(0)
FName = apiGetOpenFileName(hwnd, strFilter, "C:\Users\" & Environ("USERNAME") & "\Desktop")
If FName <> "" Then
OpenText hPracTxt, FName
End If
Case 2
DestroyWindow (hwnd)
Case 10
'OpenChooseFontがLOGFONTを返す場合
Dim lfont As LOGFONT
Dim hFont As Long
lfont = OpenChooseFont(hPracTxt)
hFont = CreateFontIndirect(ByVal VarPtr(lfont))
lngRet = SendMessage(hPracTxt, WM_SETFONT, hFont, 1)
'OpenChooseFontがCHOOSEFONT構造体を返す場合
' Dim cf As CHOOSEFONT
' Dim hFont As Long
' cf = OpenChooseFont(hPracTxt)
' Debug.Print "FONT ADDRESS" & cf.lpLogFont
'
' hFont = CreateFontIndirect(ByVal cf.lpLogFont)
' lngRet = SendMessage(hPracTxt, WM_SETFONT, hFont, 1)
Case 11
Debug.Print "11"
Dim cColor As CHOOSECOLOR
Dim CustomColors() As Byte
Dim hDCPrac As Long
Dim strTxt As String
' cColor.lStructSize = Len(cColor)
' cColor.flags = 0
' cColor.hInstance = 0
' cColor.hwndOwner = hPracTxt
' cColor.lpCustColors = StrConv(CustomColors, vbUnicode)
' lngRet = CHOOSECOLOR(cColor)
' Debug.Print "Color:" & str$(cColor.rgbResult)
' 'CustomColors = StrConv(cColor.lpCustColors, vbFromUnicode)
Debug.Print "hPracTxt:" & hPracTxt
hDCPrac = GetDC(hPracTxt)
Debug.Print "hDCPrac:" & hDCPrac
lngRet = SetTextColor(hDCPrac, RGB(255, 0, 0))
strTxt = "あいうえお"
lngRet = TextOut(hDCPrac, 0, 0, strTxt, LenB(StrConv(strTxt, vbFromUnicode)))
'
' 'lngRet = ReleaseDC(hPracTxt, hDCPrac)
Case Else
OpenText hPracTxt, ThisWorkbook.Path & "\Tmp\" & strTmp(LoWord(wParam) - 3)
End Select
End If
' If lParam = hPracTxt Then
' If wParam Mod EN_UPDATE = 0 Then
' strLen = 256
' Ret = GetWindowText(lParam, strBuff, strLen)
' MsgBox strBuff
' Else
' Debug.Print "NoEN_UPDATE" & CStr(wParam)
' End If
' End If
UpdateWindow hPracTxt
WindowProc = 0
Case WM_MENUSELECT
Debug.Print "MenuID:" & LoWord(wParam)
Debug.Print "hMenu:" & lParam
Case WM_NOTIFY
' Debug.Print "wParam" & wParam
' Debug.Print "lParam" & lParam
Dim tagNMHDR As NMHDR
Dim st As SYSTEMTIME
Dim strTime As String
strTime = String(255, vbNullChar)
CopyMemory tagNMHDR, ByVal lParam, Len(tagNMHDR)
Select Case tagNMHDR.hwndFrom
Case hPracDate
Select Case tagNMHDR.code
Case DTN_DATETIMECHANGE
Dim tagNMDATETIMECHANGE As NMDATETIMECHANGE
Dim tagSYSTEMTIME As SYSTEMTIME
CopyMemory tagNMDATETIMECHANGE, ByVal lParam, Len(tagNMDATETIMECHANGE)
' CopyMemory tagSYSTEMTIME, ByVal tagNMDATETIMECHANGE.tSYSTEMTIME, Len(tagSYSTEMTIME)
Debug.Print tagNMDATETIMECHANGE.tSYSTEMTIME.wDay
' CopyMemory tagSYSTEMTIME, ByVal lParam + Len(tagNMHDR) + 4, Len(tagSYSTEMTIME)
' Debug.Print tagSYSTEMTIME.wYear
End Select
End Select
WindowProc = 0
Case WM_HSCROLL
If lParam = hPracTrack Then
Debug.Print "H" & HiWord(wParam)
Debug.Print "L" & LoWord(wParam)
lngRet = SendMessage(hPracTrack, TBM_GETPOS, 0, 0)
Debug.Print lngRet
End If
Case WM_VSCROLL
If lParam = hPracTrack Then
Debug.Print "H" & HiWord(wParam)
Debug.Print "L" & LoWord(wParam)
End If
Case Else
WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Select
End Function
Private Function FPtr(ByVal p As Long) As Long
FPtr = p
End Function
Private Sub InsertComment(str As String)
Dim lngRow_St As Long
Dim lngCol_St As Long
Dim lngRow_Ed As Long
Dim lngCol_Ed As Long
Dim arryStr() As String
Dim strTmp As String
Dim i As Long
arryStr = Split(str, vbCrLf)
For i = 0 To UBound(arryStr)
If i = 0 Then
strTmp = "'" & arryStr(i)
Else
strTmp = strTmp & vbCrLf & "'" & arryStr(i)
End If
Next i
Application.VBE.ActiveCodePane.GetSelection lngRow_St, lngCol_St, lngRow_Ed, lngCol_Ed
Debug.Print lngRow_St
Application.VBE.ActiveCodePane.CodeModule.InsertLines lngRow_St, strTmp
End Sub
Private Function apiGetOpenFileName(nHandle As Long, nFilter As String, nDir As String) As String
Dim OFN As OPENFILENAME 'OPENFILENAME構造体
Dim Ret As Long '戻り値
With OFN '構造体の設定
.flags = OFN_PATHMUSTEXIST Or _
OFN_FILEMUSTEXIST Or _
OFN_HIDEREADONLY
'.hInstance = App.hInstance 'インスタンスハンドルを設定
.hwndOwner = nHandle 'ウインドウハンドルを設定
.lpstrTitle = "ファイルを開く" 'コモンダイアログのタイトルを設定
.lpstrFilter = nFilter 'フィルタを設定
.lStructSize = Len(OFN) '構造体のサイズを設定
.nMaxFile = 257 'ファイル名のバッファのサイズを設定
.lpstrFileTitle = String(257, Chr(0)) 'フルパス用のバッファを確保
.nMaxFileTitle = 257 'フルパス用のバッファのサイズを設定
.lpstrFile = String(257, Chr(0)) 'ファイル名のバッファを確保
.lpstrInitialDir = nDir 'デフォルトのディレクトリを指定
End With
Ret = GetOpenFileName(OFN) '「ファイルを開く」ダイアログボックスを表示する
If Ret = 0 Then '[キャンセル]を押した時、
apiGetOpenFileName = vbNullString ' ""を返す
Else '[OK]を押した時、
apiGetOpenFileName = Left(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr(0)) - 1) ' ファイル名(フルパス)を返す
End If
End Function
Private Sub OpenText(hwnd As Long, str As String)
Dim lngFN As Long
Dim strLine As String
Dim strTmp As String
Dim lngRet As Long
lngFN = FreeFile
Open str For Input As #lngFN
Do Until EOF(lngFN)
Line Input #lngFN, strLine
If strTmp = "" Then
strTmp = strLine
Else
strTmp = strTmp & vbCrLf & strLine
End If
Loop
Close lngFN
lngRet = SendMessage(hwnd, WM_SETTEXT, 0, ByVal strTmp)
End Sub
' Win32のHIWORDマクロのVB版
' MSDNの 「HOWTO: Package HiWord/LoWord Values Into a Long Parameter ID: Q189170」
Private Function HiWord(DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
' Win32のLOWORDマクロのVB版
' MSDNの 「HOWTO: Package HiWord/LoWord Values Into a Long Parameter ID: Q189170」
Private Function LoWord(DWord As Long) As Integer
If DWord And &H8000& Then ' &H8000& = &H00008000
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function
Private Function GetFontHandle(strFontName As String)
Dim i As Long
Dim lngRet As Long
Dim FName() As Byte
Dim fnt As LOGFONT
With fnt
.lfHeight = 20
.lfWidth = 10
.lfEscapement = 0
.lfOrientation = 0
.lfWeight = FW_NORMAL
FName() = StrConv(strFontName, vbFromUnicode)
For i = 0 To UBound(FName)
.lfFaceName(i) = FName(i)
Next
End With
lngRet = CreateFontIndirect(ByVal VarPtr(fnt))
GetFontHandle = lngRet
End Function
Private Sub SetM()
Dim hFont As Long
Dim lngRet As Long
hFont = GetFontHandle("メイリオ")
lngRet = SendMessage(hPracTxt, WM_SETFONT, hFont, 1)
End Sub
Private Function OpenChooseFont(hwnd As Long) As LOGFONT
Dim cf As CHOOSEFONT
Dim lfont As LOGFONT
Dim fontname As String
Dim lngRet As Long
Dim hMem As Long
Dim pMem As Long
hFont = SendMessage(hwnd, WM_GETFONT, 0, 0&)
lngRet = GetObject(hFont, Len(lfont), ByVal VarPtr(lfont))
Debug.Print lfont.lfFaceName
' lfont.lfFaceName = StrConv("ＭＳ Ｐゴシック", vbFromUnicode) & vbNullChar
' lfont.lfHeight = 10 / 0.75
' lfont.lfItalic = False
' lfont.lfUnderline = False
' lfont.lfStrikeOut = False
' lfont.lfWeight = False
' lfont.lfCharSet = 128
cf.lStructSize = Len(cf)
cf.hwndOwner = hwnd
cf.lpLogFont = VarPtr(lfont)
cf.flags = CF_INITTOLOGFONTSTRUCT Or _
CF_SCREENFONTS Or _
CF_LIMITSIZE Or _
CF_EFFECTS
cf.rgbColor = RGB(0, 0, 0)
cf.nSizeMin = 8
cf.nSizeMax = 72
lngRet = CHOOSEFONT(cf)
lfont.lfFaceName = StrConv(lfont.lfFaceName, vbUnicode) + vbNullChar
' If lngRet <> 0 Then
' CopyMemory lfont, ByVal pMem, Len(lfont)
' OpenChooseFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
' End If
Debug.Print Left(StrConv(lfont.lfFaceName, vbUnicode), InStr(StrConv(lfont.lfFaceName, vbUnicode), vbNullChar) - 1)
OpenChooseFont = lfont 'Left(StrConv(lfont.lfFaceName, vbUnicode), InStr(StrConv(lfont.lfFaceName, vbUnicode), vbNullChar) - 1)
'lngRet = GlobalUnlock(hMem)
'lngRet = GlobalFree(hMem)
End Function
'Private Function OpenChooseFont(hWnd As Long) As CHOOSEFONT
'
' Dim cf As CHOOSEFONT
' Dim lfont As LOGFONT
' Dim fontname As String
' Dim lngRet As Long
' Dim hMem As Long
' Dim pMem As Long
'
' hFont = SendMessage(hWnd, WM_GETFONT, 0, 0&)
' lngRet = GetObject(hFont, Len(lfont), ByVal VarPtr(lfont))
' Debug.Print StrConv(lfont.lfFaceName, vbUnicode) + vbNullChar
' lfont.lfFaceName = StrConv(lfont.lfFaceName, vbFromUnicode) + vbNullChar
'
' Debug.Print "FONT ADD OPC" & VarPtr(lfont)
'
'' lfont.lfFaceName = StrConv("ＭＳ Ｐゴシック", vbFromUnicode) & vbNullChar
'' lfont.lfHeight = 10 / 0.75
'' lfont.lfItalic = False
'' lfont.lfUnderline = False
'' lfont.lfStrikeOut = False
'' lfont.lfWeight = False
'' lfont.lfCharSet = 128
'
' cf.lStructSize = Len(cf)
' cf.hwndOwner = hWnd
' cf.lpLogFont = VarPtr(lfont)
' cf.Flags = CF_INITTOLOGFONTSTRUCT Or _
' CF_SCREENFONTS Or _
' CF_LIMITSIZE Or _
' CF_EFFECTS
' cf.rgbColor = RGB(0, 0, 0)
' cf.nSizeMin = 8
' cf.nSizeMax = 72
'
' lngRet = CHOOSEFONT(cf)
'
'' If lngRet <> 0 Then
'' CopyMemory lfont, ByVal pMem, Len(lfont)
'' OpenChooseFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
'' End If
' Debug.Print Left(StrConv(lfont.lfFaceName, vbUnicode), InStr(StrConv(lfont.lfFaceName, vbUnicode), vbNullChar) - 1)
' OpenChooseFont = cf
' 'Left(StrConv(lfont.lfFaceName, vbUnicode), InStr(StrConv(lfont.lfFaceName, vbUnicode), vbNullChar) - 1)
' 'lngRet = GlobalUnlock(hMem)
' 'lngRet = GlobalFree(hMem)
'End Function
Private Function GetTmpTxt() As String()
Dim strTmp() As String
Dim strFile As String
strFile = Dir(ThisWorkbook.Path & "\Tmp\")
Do Until strFile = ""
If Sgn(strTmp) = 0 Then
ReDim strTmp(0) As String
Else
ReDim Preserve strTmp(UBound(strTmp) + 1) As String
End If
strTmp(UBound(strTmp)) = strFile
strFile = Dir
Loop
GetTmpTxt = strTmp
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment