まりふのひと

令和3年 年賀状のスキャンがやっと終わった

 昨年末に弟が逝ってしまい、例年行っている年賀状(喪中も含む)のスキャンにもあまり力が入らない...
マクロ年画状の機能強化したり、ブログアップ用にWordでマクロを作ったりで時間が掛かった‥‥ ことにしよう...

年賀状をスキャンし表裏で1枚の 年画状.jpg を作る

 スキャナーは年末に更新*1 した ScanSnap S1300if:id:ogohnohito:20210124105220p:plain:right:w96設定は旧の ScanSnap S300を引き継いだので操作の変更はなかったものの、56枚でも辛かった...

f:id:ogohnohito:20210124104817p:plain

Excel住所録のハイパーリンク切れを修正

 下図は亡くなった弟の Excel住所録、

f:id:ogohnohito:20210124114345p:plain:w512

年賀状のスキャンは2015年から行っているので、2015年の年賀をクリックすると Windowsフォトビューワーで見られる‥‥ のだが、な、なんとリンク切れ~~~~~
エラーの内容を見ると‥‥ 年画状の保存先が Onedrive になっている...

  • 以前、Onedriveをバックアップに使える‥‥ と聞いたので、年画状.jpg をコピーしたことがある。
  • その時にハイパーリンクを張り替えた記憶はないが...
  • 結局、バックアップは無理だったようで、Onedriveの年画状.jpg は削除した‥‥ ようだが...
ハイパーリンクのアドレスの一部を変更するマクロ ~Replace関数~Excel(エクセル) 2013 マクロ講座

出所:なんだ!カンタン!Excel

kokodane.com

1.Sub ハイパーリンクのアドレスの一部だけ変更する1()
2.Dim h As Hyperlink
3.    For Each h In ActiveSheet.Hyperlinks
4.        h.Address = Replace(h.Address, "kokodane", "soredane")
5.    Next h
6.End Sub

 上記をVBEにコピペし、Onedriveのパスを D:\ に変更,実行して‥‥ 事なきを得た。

Excel住所録に年画状.jpg をハイパーリンクする

 年賀状を見ながら、住所録の氏名(差出人)にリンクを張るのだが、亡くなった方等のデータも持っているので、氏名を検索するのはそれなりに大変。そこで、

  • [かな]ボタンを作り、
  • かな1文字で検索し、
  • 先頭のレコードまでスクロールする

ようにした。
VBAのソースは下記、日数がかなり掛ったが、終わってヤレヤレ...

[かな]ボタンを作る VBA
01.Sub かなボタンを作る()
02.Dim strCell As String
03.
04.    With ActiveSheet.Buttons.Add( _
05.            Range("B1").Left, _
06.            Range("B1").Top, _
07.            Range("B1:B1").Width, _
08.            Range("B1:B1").Height)
09.        .OnAction = "かな検索"
10.        .Characters.Text = "かな"
11.    End With
12.
13.End Sub
[かな]ボタンクリック時のイベントプロシージャ
01.Sub かな検索()
02.Dim mbTitle As String
03.Dim strKana As String
04.
05.    mbTitle = "かな検索/" & ThisWorkbook.Name
06.    strKana = InputBox("検索するかな1文字を入力してください。", mbTitle)
07.    If strKana = "" Then Exit Sub
08.    
09.    Columns("B:B").Select
10.    Selection.Find(What:=strKana, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
11.            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
12.            , MatchByte:=False, SearchFormat:=False).Activate
13.        'アクティブセル画面左上端に表示
14.    With ActiveWindow
15.        .ScrollRow = ActiveCell.Row
16.        .ScrollColumn = ActiveCell.Column
17.    End With
18.    
19.End Sub
VBAのコードを段落番号付きのテキストにする

 当初、メモ帳に貼り付け、VBAで段落番号を付けたものを作った‥‥ が、文字化けが発生! そこで

  1. VBAのソースをWordに貼り付け
  2. 下記を実行する。
  3. メモ帳が開くので、ブログにコピペする。

 これが一番大変で、インストラクターのネタ帳にお世話になった。

01.'引用:インストラクターのネタ帳
02.'  :文字列を一行ずつ行単位で取得するWordマクロ
03.'  :https://www.relief.jp/docs/word-vba-get-text-each-line.html
04.Sub アクティブ文書の文字列を一行ずつ処理する()
05.Dim mbTitle As String
06.Const outFile As String = "C:\Users\YHayashi\Desktop\無題.txt"
07.Dim pg As Page
08.Dim rc As Rectangle
09.Dim ln As Line
10.Dim dsn As Long, keta As Long, cnt As Long
11.Dim outArea As String
12.
13.    mbTitle = "/" & ThisDocument.Name
14.    keta = InputBox("段落番号の桁数を入力してください", mbTitle, 2)
15.    If keta = 0 Then Exit Sub
16.    
17.    dsn = FreeFile
18.    Open outFile For Output As #dsn
19.    cnt = 0
20.    With ActiveWindow
21.        .View.Type = wdPrintView
22.        For Each pg In .ActivePane.Pages
23.            For Each rc In pg.Rectangles
24.                For Each ln In rc.Lines
25.                    If rc.RectangleType = wdTextRectangle Then
26.'                        MsgBox ln.Range.Text
27.                        outArea = ln.Range.Text
28.                        outArea = Left(outArea, Len(outArea) - 1)
29.                        cnt = cnt + 1
30.                        If cnt >= 10 ^ keta Then keta = keta + 1
31.                        outArea = Right("00000" & cnt, keta) & "." & outArea
32.                        Print #dsn, outArea
33.                    End If
34.                Next ln
35.            Next rc
36.        Next pg
37.    End With
38.    Close #dsn
39.        '出力したファイルをメモ帳で開く。
40.    LNGAns = Shell("notepad.exe " & outFile, vbNormalFocus)
41.    If LNGAns = 0 Then
42.        MsgBox "メモ帳の起動に失敗しました。"
43.        Exit Sub
44.    End If
45.
46.End Sub

*1:ゴムローラーが劣化し送れなくなった