'Function Module
'start from Auto_open with auto run
'
'this is created by Shu.KK(uuware.com)
'2003.01~2007.9

'********** GLOBAL DECLARATIONS **********
Private Const g_filename = "vbatools.xls"
Private Const g_menucaption = "MyTools(&1)"
Private Const g_menuloadme = "  LoadMe  "
Private Const g_lastcmdtag = "LASTCOMMAND_TAG"

'for paste picture
Private pic_paste_rate As Double
'for 条件付き書式 or 自動入力 source cell
Private sheet_filter_source As Object
'for 条件付き書式 or 自動入力 source cell
Private sheet_count_txt As String


'auto run while open this file
Sub Auto_open()
  On Error GoTo ErrorHandler
  menuadd
  baradd
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'auto run while exit excel
Sub Auto_close()
  menudel
 
  findflg = 0
  For indexi = 1 To CommandBars.Count
    Set otmp = CommandBars(indexi)
    If otmp.Name = g_menucaption Then
      findflg = 1
      Exit For
    End If
  Next

  If findflg = 1 Then
    Set mybar = CommandBars(g_menucaption)
    mybar.Visible = True
    For indexi = mybar.Controls.Count To 1 Step -1
      mybar.Controls(indexi).Delete
    Next
    Set mymenu = Application.CommandBars(g_menucaption).Controls.Add(Type:=msoControlButton)
    mymenu.Caption = g_menuloadme
    mymenu.OnAction = "Auto_open"
    mymenu.Style = msoButtonIconAndCaption
    mymenu.FaceId = 37
  End If
End Sub

Sub menuadd()
  menudel
 
  Set mymenu = CommandBars.ActiveMenuBar.Controls.Add(Type:=msoControlPopup, temporary:=True)
  mymenu.Caption = g_menucaption
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_find_replace"
  mymenu1.Caption = "Set to Menu:FindNext && Replace"
 
'sub menu
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlPopup)
  mymenu1.Caption = "Copy Format From Cell to Cell"
  mymenu1.BeginGroup = True
 
  Set submenu1 = mymenu1.Controls.Add(Type:=msoControlButton)
  submenu1.OnAction = "sheet_setcell_filterfmt"
  submenu1.Caption = "各書式設定の参照Cellを設定"
 
  Set submenu1 = mymenu1.Controls.Add(Type:=msoControlButton)
  submenu1.OnAction = "sheet_copy_filterfmt"
  submenu1.Caption = "条件付き書式をコピー"
  submenu1.BeginGroup = True
 
  Set submenu1 = mymenu1.Controls.Add(Type:=msoControlButton)
  submenu1.OnAction = "sheet_clear_filterfmt"
  submenu1.Caption = "条件付き書式をクリア"
 
  Set submenu1 = mymenu1.Controls.Add(Type:=msoControlButton)
  submenu1.OnAction = "sheet_copy_autoinput"
  submenu1.Caption = "自動入力設定をコピー"
 
  Set submenu1 = mymenu1.Controls.Add(Type:=msoControlButton)
  submenu1.OnAction = "sheet_clear_autoinput"
  submenu1.Caption = "自動入力設定をクリア"
 
  Set submenu1 = mymenu.CommandBar.Controls.Add(Type:=msoControlButton)
  submenu1.Caption = "set Paste Picture Rate(use next menu paste)"
  submenu1.OnAction = "pic_paste_setrate"
  submenu1.BeginGroup = True
  Set submenu1 = mymenu.CommandBar.Controls.Add(Type:=msoControlButton)
  submenu1.Caption = "Paste Picture from Clipboard(Data or File Copy)"
  submenu1.OnAction = "pic_paste1"
  Set submenu1 = mymenu.CommandBar.Controls.Add(Type:=msoControlButton)
  submenu1.Caption = "Paste Picture(Capture Activate Window)"
  submenu1.OnAction = "pic_paste3"
  Set submenu1 = mymenu.CommandBar.Controls.Add(Type:=msoControlButton)
  submenu1.Caption = "Paste Picture(Capture Screen)"
  submenu1.OnAction = "pic_paste4"

  Set submenu1 = mymenu.CommandBar.Controls.Add(Type:=msoControlButton)
  submenu1.Caption = "Show Help"
  submenu1.OnAction = "show_help"
  submenu1.BeginGroup = True
End Sub

Sub baradd()
  findflg = 0
  For indexi = 1 To CommandBars.Count
    Set otmp = CommandBars(indexi)
    If otmp.Name = g_menucaption Then
      findflg = 1
      Exit For
    End If
  Next

  'not delete for set at same position
  If findflg = 0 Then
    Set mybar = CommandBars.Add(Name:=g_menucaption)
  Else
    Set mybar = CommandBars(g_menucaption)
  End If
  mybar.Visible = True
 
  For indexi = mybar.Controls.Count To 1 Step -1
    If mybar.Controls(indexi).Caption = g_menuloadme Then
      mybar.Controls(indexi).Visible = False
    Else
      mybar.Controls(indexi).Delete
    End If
  Next
 
  Set mymenu = CommandBars(g_menucaption).Controls.Add(Type:=msoControlButton)
  mymenu.OnAction = "sheet_paste_text"
  mymenu.Caption = "Paste as Text to ActiveCell"
  mymenu.Style = msoButtonIcon
  mymenu.FaceId = 9

  Set mymenu = CommandBars(g_menucaption).Controls.Add(Type:=msoControlButton)
  mymenu.OnAction = "sheet_turncliptxt"
  mymenu.Caption = "Turn ClipBoard to Text(Clear Format)"
  mymenu.Style = msoButtonIcon
  mymenu.FaceId = 219
 
  Set mymenu = CommandBars(g_menucaption).Controls.Add(Type:=msoControlPopup)
  mymenu.Caption = "▽"

  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_paste_textl"
  mymenu1.Caption = "Paste to current Cell's Left"
  mymenu1.FaceId = 198
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_paste_textr"
  mymenu1.Caption = "Paste to current Cell's Right"
  mymenu1.FaceId = 199
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_sendkey_text"
  mymenu1.Caption = "Send ClipBoard as Keys(Text)"
  mymenu1.FaceId = 64

  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turn_Big"
  mymenu1.Caption = "(&a)turn '小文字' to '大文字'"
  mymenu1.BeginGroup = True
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turn_Small"
  mymenu1.Caption = "(&b)turn '大文字' to '小文字'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turntenx"
  mymenu1.Caption = "(&x)turn '半角（全て）' to '全角'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnteny"
  mymenu1.Caption = "(&y)turn '全角（全て）' to '半角'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnto_"
  mymenu1.Caption = "(&2)turn '-' to '_'"
  mymenu1.BeginGroup = True
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnto_2"
  mymenu1.Caption = "(&3)turn '_' to '-'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnkaku1"
  mymenu1.Caption = "(&4)turn '半角()' to '全角（）'"
  mymenu1.BeginGroup = True
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnkaku2"
  mymenu1.Caption = "(&5)turn '全角（）' to '半角()'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnten"
  mymenu1.Caption = "(&6)turn '半角.' to '全角．'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.OnAction = "sheet_turnten2"
  mymenu1.Caption = "(&7)turn '全角．' to '半角.'"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.Caption = "Cell(s)'s Value++"
  mymenu1.OnAction = "sheet_cell_up"
  mymenu1.BeginGroup = True
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.Caption = "Cell(s)'s Value--"
  mymenu1.OnAction = "sheet_cell_down"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.Caption = "Count the txt in selected Selection(one cell only once)"
  mymenu1.OnAction = "sheet_count_one"
  mymenu1.BeginGroup = True
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.Caption = "Count the txt in selected Selection(one cell any times)"
  mymenu1.OnAction = "sheet_count_n"
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.Caption = "UnloadMe(can Loadme again)"
  mymenu1.OnAction = "auto_close"
  mymenu1.Style = msoButtonIconAndCaption
  mymenu1.FaceId = 330
  mymenu1.BeginGroup = True
 
  Set mymenu1 = mymenu.Controls.Add(Type:=msoControlButton)
  mymenu1.Caption = "Delete Me(Never Show)"
  mymenu1.OnAction = "DeleteMenuBar"
  mymenu1.Style = msoButtonIconAndCaption
  mymenu1.FaceId = 358
End Sub

Sub menudel()
  For Index = CommandBars.ActiveMenuBar.Controls.Count To 1 Step -1
    Set otmp = CommandBars.ActiveMenuBar.Controls(Index)
    If otmp.Caption = g_menucaption Or otmp.Tag = g_lastcmdtag Or otmp.Tag = g_lastcmdtag & "2" Then
      otmp.Delete
    End If
  Next
End Sub

Sub bardel()
  For indexi = CommandBars.Count To 1 Step -1
    Set otmp = CommandBars(indexi)
    If otmp.Name = g_menucaption Then
      otmp.Delete
      Exit For
    End If
  Next
End Sub

Sub DeleteMenuBar()
  menudel
  bardel
End Sub

Sub show_help()
  'show this file
  For Index = 1 To Windows.Count
    If LCase(Windows.Item(Index).Caption) = g_filename Then
      'isSaved = Workbooks(g_filename).Saved
      Windows.Item(Index).Visible = True
      Workbooks(g_filename).Activate
      'Workbooks(g_filename).Saved = isSaved
      Exit For
    End If
  Next
End Sub

Sub hide_help()
  'hide this file
  For Index = 1 To Windows.Count
    If LCase(Windows.Item(Index).Caption) = g_filename Then
      'isSaved = Workbooks(g_filename).Saved
      Windows.Item(Index).Visible = False
      'Workbooks(g_filename).Saved = isSaved
      Exit For
    End If
  Next
End Sub

'Save Last command to LASTCOMMAND menu
Sub lastcmd(strAction, strCaption)
  If Len(strCaption) > 20 Then
    strCaption = Left(strCaption, 20) & "..."
  End If
 
  'if exist do nothing
  For Index = 1 To CommandBars.ActiveMenuBar.Controls.Count
    Set otmp = CommandBars.ActiveMenuBar.Controls(Index)
    If otmp.Tag = g_lastcmdtag Or otmp.Tag = g_lastcmdtag & "2" Then
      If Right(otmp.OnAction, Len(strAction)) = strAction And otmp.Caption = strCaption Then
        Exit Sub
      End If
    End If
  Next
  'set Last1 to Last2,and set current to Last1
  For Index = 1 To CommandBars.ActiveMenuBar.Controls.Count
    Set otmp = CommandBars.ActiveMenuBar.Controls(Index)
    If otmp.Tag = g_lastcmdtag Then
      lastcmd2 otmp.OnAction, otmp.Caption
      otmp.OnAction = strAction
      otmp.Caption = strCaption
      Exit Sub
    End If
  Next
  Set mymenu = CommandBars.ActiveMenuBar.Controls.Add(Type:=msoControlButton, temporary:=True)
  mymenu.Caption = strCaption
  mymenu.Tag = g_lastcmdtag
  mymenu.OnAction = strAction
  mymenu.Style = msoButtonIconAndCaption
  mymenu.FaceId = 282
End Sub

'Save Last command to LASTCOMMAND2
Sub lastcmd2(strAction, strCaption)
  If Len(strCaption) > 20 Then
    strCaption = Left(strCaption, 20) & "..."
  End If
 
  For Index = 1 To CommandBars.ActiveMenuBar.Controls.Count
    Set otmp = CommandBars.ActiveMenuBar.Controls(Index)
    If otmp.Tag = g_lastcmdtag & "2" Then
      otmp.OnAction = strAction
      otmp.Caption = strCaption
      Exit Sub
    End If
  Next
  Set mymenu = CommandBars.ActiveMenuBar.Controls.Add(Type:=msoControlButton, temporary:=True)
  mymenu.Caption = strCaption
  mymenu.Tag = g_lastcmdtag & "2"
  mymenu.OnAction = strAction
  mymenu.Style = msoButtonIconAndCaption
  mymenu.FaceId = 282
End Sub

'take Tab and CR at right
Function Trim_RTab(strString As String) As String
  For i = 1 To Len(strString)
    intTmp = Asc(Right(strString, i))
    If Not (intTmp = 9 Or intTmp = 10 Or intTmp = 13) Then
      Exit For
    End If
  Next
  Trim_RTab = Left(strString, Len(strString) - i + 1)
End Function

'Turn ClipBoard to Text(Clear Format)
Sub sheet_turncliptxt()
  'lastcmd "sheet_turncliptxt", "Turn ClipBoard to Text"
  ClipBoard_SetText ClipBoard_GetText
End Sub

'Paste as Text to ActiveCell(only one cell)
Sub sheet_paste_text()
On Error GoTo ErrorHandler
  'lastcmd "sheet_paste_text", "Paste as Text"
  ActiveCell = Trim_RTab(ClipBoard_GetText)
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'Paste to current Cell's Left
Sub sheet_paste_textl()
On Error GoTo ErrorHandler
  lastcmd "sheet_paste_textl", "Paste to Cell's Left"
  ActiveCell = Trim_RTab(ClipBoard_GetText) & ActiveCell
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'Paste to current Cell's Right
Sub sheet_paste_textr()
On Error GoTo ErrorHandler
  lastcmd "sheet_paste_textr", "Paste to Cell's Right"
  ActiveCell = ActiveCell & Trim_RTab(ClipBoard_GetText)
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

Sub sheet_sendkey_text()
On Error GoTo ErrorHandler
  lastcmd "sheet_sendkey_text", "Send ClipBoard as Keys(Text)"
  strtmp = Trim_RTab(ClipBoard_GetText)
  ClipBoard_SetText "" & strtmp
  strtmp = Replace(strtmp, "{", "_Skk_" & "_sKK_")
  strtmp = Replace(strtmp, "}", "{}}")
  strtmp = Replace(strtmp, "_Skk_" & "_sKK_", "{{}")
  strtmp = Replace(strtmp, "+", "{+}")
  strtmp = Replace(strtmp, "^", "{^}")
  strtmp = Replace(strtmp, "%", "{%}")
  strtmp = Replace(strtmp, "~", "{~}")
  strtmp = Replace(strtmp, "(", "{(}")
  strtmp = Replace(strtmp, ")", "{)}")
  SendKeys strtmp, True
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'小文字' to '大文字'
Sub sheet_turn_Big()
On Error GoTo ErrorHandler
  lastcmd "sheet_turn_Big", "小文字' to '大文字'"
  ActiveCell = UCase(ActiveCell)
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'大文字' to '小文字'
Sub sheet_turn_Small()
On Error GoTo ErrorHandler
  lastcmd "sheet_turn_Small", "大文字' to '小文字'"
  ActiveCell = LCase(ActiveCell)
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'StrConv
'vbUpperCase     1   大文字に変換
'vbLowerCase     2   小文字に変換
'vbProperCase    3   各単語の先頭の文字を大文字に変換
'vbWide  4   半角文字を全角文字に変換
'vbNarrow    8   全角文字を半角文字に変換
'vbKatakana  16  ひらがなをカタカナに変換
'vbHiragana  32  カタカナをひらがなに変換
'半角==>全角
Sub sheet_turntenx()
On Error GoTo ErrorHandler
  lastcmd "sheet_turntenx", "半角==>全角"
  ActiveCell = StrConv(ActiveCell, 4)
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'半角==>全角
Sub sheet_turnteny()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnteny", "全角==>半角"
  ActiveCell = StrConv(ActiveCell, 8)
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'turn - to '_'
Sub sheet_turnto_()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnto_", "turn - to '_'"
  ActiveCell = Replace(ActiveCell, "-", "_")
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'turn _ to '-'
Sub sheet_turnto_2()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnto_2", "turn _ to '-'"
  ActiveCell = Replace(ActiveCell, "_", "-")
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'()半角==>全角（）
Sub sheet_turnkaku1()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnkaku1", "半角()==>全角（）"
  ActiveCell = Replace(ActiveCell, "(", "（")
  ActiveCell = Replace(ActiveCell, ")", "）")
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'全角==>半角
Sub sheet_turnkaku2()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnkaku2", "全角（）==>半角()"
  ActiveCell = Replace(ActiveCell, "（", "(")
  ActiveCell = Replace(ActiveCell, "）", ")")
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'半角.==>全角．
Sub sheet_turnten()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnten", "半角.==>全角．"
  ActiveCell = Replace(ActiveCell, ".", "．")
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'半角.==>全角．
Sub sheet_turnten2()
On Error GoTo ErrorHandler
  lastcmd "sheet_turnten2", "全角．==>半角."
  ActiveCell = Replace(ActiveCell, "．", ".")
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'Cell(s)'s Value++
Sub sheet_cell_up()
On Error GoTo ErrorHandler
  lastcmd "sheet_cell_up", "Cell(s)'s Value++"
  For Each cell In Selection
    scell = "" & cell
    If IsNumeric(scell) Then
      cell.Value = scell + 1
    Else
      nInd = -1
      For i = Len(scell) To 1 Step -1
        sone = Mid(scell, i, 1)
        If IsNumeric(sone) And sone <> "-" And sone <> "+" Then
          nInd = i
        Else
          Exit For
        End If
      Next
      If nInd > 0 Then
        sfirst = Mid(scell, 1, nInd - 1)
        slast = Mid(scell, nInd) + 1
        cell.Value = sfirst & slast
      End If
    End If
  Next

Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'Cell(s)'s Value--
Sub sheet_cell_down()
On Error GoTo ErrorHandler
  lastcmd "sheet_cell_down", "Cell(s)'s Value--"
  For Each cell In Selection
    scell = "" & cell
    If IsNumeric(scell) Then
      cell.Value = scell - 1
    Else
      nInd = -1
      For i = Len(scell) To 1 Step -1
        sone = Mid(scell, i, 1)
        If IsNumeric(sone) And sone <> "-" And sone <> "+" Then
          nInd = i
        Else
          Exit For
        End If
      Next
      If nInd > 0 Then
        sfirst = Mid(scell, 1, nInd - 1)
        slast = Mid(scell, nInd) - 1
        If slast >= 0 Then
          cell.Value = sfirst & slast
        End If
      End If
    End If
  Next

Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'Count the txt(one cell +1)
Sub sheet_count_one()
  lastcmd "sheet_count_one", "Count(one cell +1)"

  txtfind = InputBox("One Cell only count once" & vbCrLf & "Please input what to count:", "Count(one cell +1)", sheet_count_txt)
  If Trim(txtfind) = "" Then
    Exit Sub
  End If
  sheet_count_txt = txtfind
  cnt = 0
  For Each cell In Selection
    If InStr(1, "" & cell, txtfind) > 0 Then
      cnt = cnt + 1
    End If
  Next
  MsgBox "Fount " & txtfind & ":" & cnt
End Sub

'Count the txt(one cell +n)
Sub sheet_count_n()
  lastcmd "sheet_count_n", "Count(one cell +n)"

  txtfind = InputBox("One Cell can count more than once" & vbCrLf & "Please input what to count:", "Count(one cell +n)", sheet_count_txt)
  If Trim(txtfind) = "" Then
    Exit Sub
  End If
  sheet_count_txt = txtfind
  cnt = 0
  nLen = Len(txtfind)
  For Each cell In Selection
    nPos = InStr(1, "" & cell, txtfind)
    Do While (nPos > 0)
      cnt = cnt + 1
      nPos = InStr(nPos + nLen, "" & cell, txtfind)
    Loop
  Next
  MsgBox "Fount " & txtfind & ":" & cnt
End Sub

'Set to Menu:FindNext & Replace ActiveCell
Sub sheet_find_replace()
  lastcmd "sheet_find_next", "FindNext"
  lastcmd2 "sheet_replace_ActiveCell", "ReplaceActiveCell"
  MsgBox "Here only add ""FindNext"" and ""Replace"" menu. you need to do some System's Find&Replace first then can use this."
End Sub

'do FindNext(you need do system's find first)
Sub sheet_find_next()
On Error Resume Next
  Cells.FindNext(After:=ActiveCell).Activate
End Sub

'do Replace(you need do system's replace first)
Sub sheet_replace_ActiveCell()
On Error Resume Next
  If TypeName(Selection) = "Range" Then
    ActiveCell.Replace LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
  Else
    MsgBox "need select a Cell to do Replace"
  End If
End Sub

'set 条件付き書式 or 自動入力 source cell
Sub sheet_setcell_filterfmt()
  If TypeName(Selection) = "Range" Then
    Set sheet_filter_source = ActiveCell
    'MsgBox "各書式設定の参照Cellを設定しました。"
  Else
    MsgBox "need select a Cell."
  End If
End Sub

'条件付き書式をクリア
Sub sheet_clear_filterfmt()
On Error GoTo ErrorHandler
  lastcmd "sheet_clear_filterfmt", "条件付き書式をクリア"
  Selection.FormatConditions.Delete
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'条件付き書式をコピー
Sub sheet_copy_filterfmt()
On Error GoTo ErrorHandler
  lastcmd "sheet_copy_filterfmt", "条件付き書式をコピー"
  If TypeName(sheet_filter_source) <> "Range" Then
    MsgBox "先に「各書式設定の参照Cellを設定」が必要です。"
    Exit Sub
  End If
  If sheet_filter_source.Address = ActiveCell.Address Then
    MsgBox "コピー元と同じCellです。別のCellに指定下さい。"
    Exit Sub
  End If
  nCount = sheet_filter_source.FormatConditions.Count
  If nCount = 0 Then
    MsgBox "選択したCellに条件付き書式がありません。"
    Exit Sub
  End If
 
  'copy it
  Selection.FormatConditions.Delete
  For i = 1 To nCount
    If sheet_filter_source.FormatConditions(i).Type = 1 Then
      If sheet_filter_source.FormatConditions(i).Operator = 1 Or sheet_filter_source.FormatConditions(i).Operator = 2 Then
        Selection.FormatConditions.Add Type:=sheet_filter_source.FormatConditions(i).Type, _
        Operator:=sheet_filter_source.FormatConditions(i).Operator, _
        Formula1:=sheet_filter_source.FormatConditions(i).Formula1, _
        Formula2:=sheet_filter_source.FormatConditions(i).Formula2
      Else
        Selection.FormatConditions.Add Type:=sheet_filter_source.FormatConditions(i).Type, _
        Operator:=sheet_filter_source.FormatConditions(i).Operator, _
        Formula1:=sheet_filter_source.FormatConditions(i).Formula1
      End If
    Else
      Selection.FormatConditions.Add Type:=sheet_filter_source.FormatConditions(i).Type, _
      Formula1:=sheet_filter_source.FormatConditions(i).Formula1
    End If
  Next
  For i = nCount To 1 Step -1
    With Selection.FormatConditions(i).Font
      .Underline = sheet_filter_source.FormatConditions(i).Font.Underline
      .ColorIndex = sheet_filter_source.FormatConditions(i).Font.ColorIndex
      .Bold = sheet_filter_source.FormatConditions(i).Font.Bold
      .Italic = sheet_filter_source.FormatConditions(i).Font.Italic
      .Strikethrough = sheet_filter_source.FormatConditions(i).Font.Strikethrough
    End With
    If sheet_filter_source.FormatConditions(i).Borders.Value = 1 Then
      Selection.FormatConditions(i).Borders(xlLeft).LineStyle = sheet_filter_source.FormatConditions(i).Borders(xlLeft).LineStyle
      Selection.FormatConditions(i).Borders(xlLeft).Weight = sheet_filter_source.FormatConditions(i).Borders(xlLeft).Weight
      Selection.FormatConditions(i).Borders(xlLeft).Color = sheet_filter_source.FormatConditions(i).Borders(xlLeft).Color
      Selection.FormatConditions(i).Borders(xlLeft).ColorIndex = sheet_filter_source.FormatConditions(i).Borders(xlLeft).ColorIndex
      Selection.FormatConditions(i).Borders(xlRight).LineStyle = sheet_filter_source.FormatConditions(i).Borders(xlRight).LineStyle
      Selection.FormatConditions(i).Borders(xlRight).Weight = sheet_filter_source.FormatConditions(i).Borders(xlRight).Weight
      Selection.FormatConditions(i).Borders(xlRight).Color = sheet_filter_source.FormatConditions(i).Borders(xlRight).Color
      Selection.FormatConditions(i).Borders(xlRight).ColorIndex = sheet_filter_source.FormatConditions(i).Borders(xlRight).ColorIndex
      Selection.FormatConditions(i).Borders(xlTop).LineStyle = sheet_filter_source.FormatConditions(i).Borders(xlTop).LineStyle
      Selection.FormatConditions(i).Borders(xlTop).Weight = sheet_filter_source.FormatConditions(i).Borders(xlTop).Weight
      Selection.FormatConditions(i).Borders(xlTop).Color = sheet_filter_source.FormatConditions(i).Borders(xlTop).Color
      Selection.FormatConditions(i).Borders(xlTop).ColorIndex = sheet_filter_source.FormatConditions(i).Borders(xlTop).ColorIndex
      Selection.FormatConditions(i).Borders(xlBottom).LineStyle = sheet_filter_source.FormatConditions(i).Borders(xlBottom).LineStyle
      Selection.FormatConditions(i).Borders(xlBottom).Weight = sheet_filter_source.FormatConditions(i).Borders(xlBottom).Weight
      Selection.FormatConditions(i).Borders(xlBottom).Color = sheet_filter_source.FormatConditions(i).Borders(xlBottom).Color
      Selection.FormatConditions(i).Borders(xlBottom).ColorIndex = sheet_filter_source.FormatConditions(i).Borders(xlBottom).ColorIndex
    End If
    With Selection.FormatConditions(i).Interior
      If sheet_filter_source.FormatConditions(i).Interior.ColorIndex > 0 Then
        .ColorIndex = sheet_filter_source.FormatConditions(i).Interior.ColorIndex
      End If
      If sheet_filter_source.FormatConditions(i).Interior.PatternColorIndex > 0 Then
        .PatternColorIndex = sheet_filter_source.FormatConditions(i).Interior.PatternColorIndex
      End If
      If sheet_filter_source.FormatConditions(i).Interior.Pattern > 0 Then
        .Pattern = sheet_filter_source.FormatConditions(i).Interior.Pattern
      End If
    End With
  Next
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'自動入力設定をクリア
Sub sheet_clear_autoinput()
On Error GoTo ErrorHandler
  lastcmd "sheet_clear_autoinput", "自動入力設定をクリア"
  Selection.Validation.Delete
Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'自動入力設定をコピー
Sub sheet_copy_autoinput()
On Error GoTo ErrorHandler
  lastcmd "sheet_copy_autoinput", "自動入力設定をコピー"
 
  If TypeName(sheet_filter_source) <> "Range" Then
    MsgBox "先に「各書式設定の参照Cellを設定」が必要です。"
    Exit Sub
  End If
  If sheet_filter_source.Address = ActiveCell.Address Then
    MsgBox "コピー元と同じCellです。別のCellに指定下さい。"
    Exit Sub
  End If
 
  'do it
  Selection.Validation.Delete
  With Selection.Validation
    .Add Type:=sheet_filter_source.Validation.Type, AlertStyle:=sheet_filter_source.Validation.AlertStyle, Operator:= _
      sheet_filter_source.Validation.Operator, Formula1:=sheet_filter_source.Validation.Formula1, _
      Formula2:=sheet_filter_source.Validation.Formula2
    .IgnoreBlank = sheet_filter_source.Validation.IgnoreBlank
    .InCellDropdown = sheet_filter_source.Validation.InCellDropdown
    '.InputTitle = sheet_filter_source.Validation.InputTitle
    '.ErrorTitle = sheet_filter_source.Validation.ErrorTitle
    .InputMessage = sheet_filter_source.Validation.InputMessage
    .ErrorMessage = sheet_filter_source.Validation.ErrorMessage
    .IMEMode = sheet_filter_source.Validation.IMEMode
    .ShowInput = sheet_filter_source.Validation.ShowInput
    .ShowError = sheet_filter_source.Validation.ShowError
  End With

Exit Sub
ErrorHandler:
    Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbCritical, "エラー"
End Sub

'set Paste Picture Rate(use next menu paste)
Sub pic_paste_setrate()
  If pic_paste_rate <= 0 Or pic_paste_rate > 2 Then
    pic_paste_rate = 1
  End If
  txtfind = InputBox("Please input Rate to change:", "0.1 ~ 2", pic_paste_rate)
  If Not IsNumeric(txtfind) Then
    MsgBox "not valid for input!"
    Exit Sub
  End If
  nrate = 0 + txtfind
  If nrate <= 0 Or nrate > 2 Then
    MsgBox "not valid for input!"
    Exit Sub
  End If
  pic_paste_rate = nrate
End Sub

Sub pic_paste1()
  lastcmd "pic_paste1", "Paste Picture(Clipboard)"
  pic_paste_main
End Sub

Sub pic_paste_main()
  On Error GoTo ErrorHandler
 
  If pic_paste_rate <= 0 Or pic_paste_rate > 2 Then
    pic_paste_rate = 1
  End If
 
  'if is paste(insert) pic from Clipboard(select file and Ctrl+C)
  sFile = ""
  If IsClipboardFormatAvailable(CF_HDROP) Then
    sAllFile = ClipBoard_GetFiles()
    If sAllFile <> "" And InStr(sAllFile, "|") > 0 Then
      sFileArr = Split(sAllFile, "|")
      If UBound(sFileArr) - LBound(sFileArr) > 1 Then
        MsgBox "Can only treate one file!"
        Exit Sub
      End If
      sFile = sFileArr(LBound(sFileArr))
    End If
  End If
    
  nT = -1
  nL = -1
  'if selected picture already,delete it(and save position)
  If TypeName(Selection) = "Picture" Then
    nT = Selection.Top
    nL = Selection.Left
    Selection.Delete
  End If
  If sFile <> "" Then
    'if error will goto ErrorHandler to show excel's onwer error
    ActiveSheet.Pictures.Insert(sFile).Select
  Else
    'others just paste(perhaps paste some text,...)
    ActiveSheet.Paste
  End If
  If TypeName(Selection) = "Picture" Then
    'Width will be auto adjust
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = Selection.ShapeRange.Height * pic_paste_rate
    'if need pagedown
    'ActiveWindow.LargeScroll Down:=1
    'ActiveWindow.ScrollRow = Selection.BottomRightCell.Row
    If nT > 0 And nL > 0 Then
      Selection.Top = nT
      Selection.Left = nL
    End If
  End If
Exit Sub
ErrorHandler:
  Msg = "エラー：" & Str(Err.Number) & Chr(13) & Chr(13) & Err.Description
  MsgBox Msg, vbCritical, "エラー"
End Sub

'Paste Picture(Capture next Activate Window)
Sub pic_paste3()
  lastcmd "pic_paste3", "Capture&&Paste Window"

  Application.Visible = False
  endtime = Timer + 1
  Do While (endtime > Timer)
    DoEvents
  Loop
  CaptureWin True
  Application.Visible = True
  DoEvents
  pic_paste_main
End Sub

'Paste Picture(Capture Screen)
Sub pic_paste4()
  lastcmd "pic_paste4", "Capture&&Paste Screen"

  Application.Visible = False
  endtime = Timer + 1
  Do While (endtime > Timer)
    DoEvents
  Loop
  CaptureWin False
  Application.Visible = True
  DoEvents
  pic_paste_main
End Sub

'API Module
'
'this is created by Shu.KK(uuware.com)
'2003.01~2007.9

'********** BEGIN WINDOWS API DECLARATIONS **********
Public Const CF_TEXT = 1
Public Const CF_BITMAP = 2
Public Const CF_DIB = 8
Public Const CF_HDROP = 15 'for files
Public Const MAX_PATH As Long = 260
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = &H42

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) 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 GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemoryLS Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByVal dest As Any, ByVal src As Any, ByVal n As Long)

Public Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Const VK_MENU = &H12
Private Const VK_LMENU = &HA4
Private Const VK_SNAPSHOT = &H2C
Private Const VK_CONTROL = &H11
Private Const VK_V = &H56
Private Const VK_0x79 = &H79
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
'********** END WINDOWS CLIPBOARD DECLARATIONS **********

Function ClipBoard_SetText(strCopyString As String) As Boolean           'used for Clipboard button
   Dim hGlobalMemory As Long, lpGlobalMemory As Long, hClipMemory As Long

   strlen = LenB(StrConv(strCopyString, vbFromUnicode))
   ' Allocate moveable global memory
   hGlobalMemory = GlobalAlloc(GHND, strlen + 1)
   ' Lock block to get far pointer to this memory
   lpGlobalMemory = GlobalLock(hGlobalMemory)
   ' Copy the string to global memory
   CopyMemoryLS lpGlobalMemory, strCopyString, strlen
   ' Unlock memory then copy to clipboard
   If GlobalUnlock(hGlobalMemory) = 0 Then
      If OpenClipboard(0&) <> 0 Then
      'If OpenClipboard(Screen.ActiveForm.Hwnd) <> 0 Then   'can't use when debugging
         Call EmptyClipboard
         hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
         ClipBoard_SetText = CBool(CloseClipboard)
      End If
   End If
End Function

Function ClipBoard_GetText() As String
   Dim hClipMemory As Long, lpClipMemory As Long, strCBText As String
   Dim RetVal As Long, lngSize As Long
   
   If OpenClipboard(0&) <> 0 Then
   'If OpenClipboard(Screen.ActiveForm.Hwnd) <> 0 Then      'can't use when debugging
   'Get handle to global memory block that is referencing the text
      hClipMemory = GetClipboardData(CF_TEXT)
      If hClipMemory <> 0 Then
         'Lock Clipboard memory so we can reference the actual data string
         lpClipMemory = GlobalLock(hClipMemory)
         If lpClipMemory <> 0 Then
            lngSize = GlobalSize(lpClipMemory)              'size of string in clipboard
            strCBText = Space$(lngSize)                     'make VBA string to hold clipboard data
            CopyMemoryLS strCBText, lpClipMemory, lngSize   'copy from clipboard to our string
            RetVal = GlobalUnlock(hClipMemory)              'unlock the memory
            'Remove the null terminating character
            strCBText = Left(strCBText, InStr(1, strCBText, Chr$(0), 0) - 1)
         Else
            MsgBox "Could not lock memory to copy string from."
         End If
      End If
      Call CloseClipboard     'close the clipboard
   End If
   ClipBoard_GetText = strCBText
End Function

Function ClipBoard_GetFiles() As String
    Dim sData     As String
    Dim hDrop     As Long
    Dim nFiles    As Long
    Dim i         As Long
    Dim desc      As String
    Dim filename  As String
    Dim Files()   As String
    
    ClipBoard_GetFiles = ""
    If OpenClipboard(0&) <> 0 Then
        Dim hMemHandle As Long, lpData As Long
        Dim nClipSize As Long
        
        hDrop = GetClipboardData(CF_HDROP)
        If hDrop <> 0 Then
            'Get   count   of   files
            nFiles = DragQueryFile(hDrop, -1&, "", 0)
            
            ReDim Files(0 To nFiles - 1) As String
            Dim strAllFile As String
            
            filename = Space(MAX_PATH)
            For i = 0 To nFiles - 1
                'Retrieves   the   names   of   copied   files
                Call DragQueryFile(hDrop, i, filename, Len(filename))
                Files(i) = TrimNull(filename)
                
                strAllFile = strAllFile + Files(i)
                strAllFile = strAllFile + "|"
            Next i
            
            'return   the   copied   files
            ClipBoard_GetFiles = strAllFile
            Call CloseClipboard
        End If
    End If
End Function

Private Function TrimNull(ByVal StrIn As String) As String
    Dim nul As Long
    nul = InStr(StrIn, vbNullChar)
    Select Case nul
    Case Is > 1
        TrimNull = Left(StrIn, nul - 1)
    Case 1
        TrimNull = ""
    Case 0
        TrimNull = Trim(StrIn)
    End Select
End Function

Public Sub CaptureWin(isScreen)
  VBA.DoEvents
  If isScreen Then
    alt_scan_code = MapVirtualKey(VK_MENU, 0)
    keybd_event VK_MENU, alt_scan_code, 0, 0
  End If
  keybd_event VK_SNAPSHOT, 0, 0, 0
  If isScreen Then
    keybd_event VK_MENU, alt_scan_code, KEYEVENTF_KEYUP, 0
  End If
  VBA.DoEvents
End Sub