顯示具有 Excel & VBA 標籤的文章。 顯示所有文章
顯示具有 Excel & VBA 標籤的文章。 顯示所有文章

2024年5月3日 星期五

VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF 4

在前一篇 VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF 3
曾經思考有沒有辦法不用先產生檔案的方式
轉了很多彎，後來看PyPDF2的說明
PdfWriter()的write()參數，可以是個路徑 
:param stream: An object to write the file to. The object can support
   the write method and the tell method, similar to a file object, or
   be a file path, just like the fileobj, just named it stream to keep
   existing workflow.
這就代表不需要是實體檔案路徑
所以改寫程式碼如下 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 
import os, sys
from PyPDF2 import PdfReader 
from PyPDF2 import PdfWriter

def addPw(ar1, ar2):
    #print(ar1,ar2)
    pdf_path =ar1
    pswd=ar2
    
    #不含副檔名的檔案名稱
    fileName = os.path.basename(pdf_path).replace(".pdf", "")

    #最後輸出的檔案路徑  因為檔案加密之後 不能寫回原本的檔案   
    newFile = os.path.dirname(pdf_path)+"\\"+ fileName +"_pw.pdf"    
    
    #讀取原始檔案
    in_file = open(pdf_path, "r+b")
    in_pdf = PdfReader(in_file)
    
    #加密檔案
    out_pdf = PdfWriter()
    out_pdf.append_pages_from_reader(in_pdf)
    out_pdf.encrypt(pswd)
    
    #寫出檔案
    out_pdf.write(newFile)
    
    #關閉open()開啟的檔案
    in_file.close()

    #刪除PdfReader() PdfWriter()
    del in_pdf, out_pdf
    #print("檔案加密完成")
    
addPw(sys.argv[1], sys.argv[2])

#測試用
#addPw(r"D:\Google 雲端硬碟\莊生的箱子\網站_程式練習\VBA練習\PDF 轉檔 加密\output\臺北市.pdf","123456")
#addPw(r"D:\Google 雲端硬碟\莊生的箱子\網站_程式練習\python練習\創建PDF\output\臺北市.pdf","123456")
 

VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF 3

再次修改 VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF 的程式碼
1.使用 WScript.Shell 執行命令列、2.在迴圈增加 "DoEvents" 移交控制權
這次是修改python程式碼
原本的程式碼透過 shutil套件複製檔案2次
1個用來增加密碼
1個是用來寫入增加密碼的PDF
而原因是增加密碼的PDF無法寫回原檔案
後來覺得能否可以不用複製檔案??
目前的作法是用 fitz套件產生一個有一頁空白A4的實體PDF
然後用 PyPDF2套件的 pdfReader讀取原始檔
再用PyPDF2套件的 PdfWriter的append_pages_from_reader附加pdfReader
用encrypt增加密碼
最後再寫入空白A4的實體PDF
流程如下
#2 引入 fitz套件
備註：安裝套件要使用這個名稱「PyMuPDF」
#15-22 產生一個一頁A4空白頁的PDF
之後加密的流程大同小異
修改後的程式碼如下 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
 
import os, sys
import fitz
from PyPDF2 import PdfReader 
from PyPDF2 import PdfWriter

def addPw(ar1, ar2):
    #print(ar1,ar2)
    pdf_path =ar1
    pswd=ar2
    
    #不含副檔名的檔案名稱
    fileName = os.path.basename(pdf_path).replace(".pdf", "")
    #print(fileName)
    
    #產生一個A4空白頁的PDF
    doc = fitz.open()
    #To add a blank page,
    w, h = fitz.paper_size("A4") 
    # -1, insertion point: end of document
    doc.new_page(-1, width = w, height = h)    
    newFile = os.path.dirname(pdf_path)+"\\"+ fileName +"_pw.pdf"
    doc.save(newFile)
    #print(newFile)
    
    #讀取檔案
    in_file = open(pdf_path, "r+b")
    in_pdf = PdfReader(in_file)
    
    #加密檔案
    out_pdf = PdfWriter()
    out_pdf.append_pages_from_reader(in_pdf)
    out_pdf.encrypt(pswd)
    
    #讀取用來存儲的檔案
    out_file = open(newFile, "wb")
    #寫出檔案
    out_pdf.write(out_file)
    
    #關閉open()開啟的檔案
    in_file.close()
    out_file.close()
    #刪除PdfReader() PdfWriter()
    del in_pdf, out_pdf
    #print("檔案加密完成")
    
addPw(sys.argv[1], sys.argv[2])

#測試用
#addPw(r"D:\Google 雲端硬碟\莊生的箱子\網站_程式練習\python練習\創建PDF\output\臺北市.pdf","123456")

2024年4月30日 星期二

VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF 2

本篇主要修改 VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF的程式碼
讓程式執行更為流暢
主要修改的地方有以下兩點

1.使用 WScript.Shell 執行命令列

因為WScript.Shell可以透過第3個參數 waitOnReturn=True，來讓程式同步執行(一個執行完畢，再執行下一個，依序執行)

2.在迴圈增加 "DoEvents" 移交控制權

這樣可以讓程式在執行會花比較久時間的流程時，讓系統還可以做其他的事情

修改後的VBA 程式碼如下 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
 
'
'透過WScript.Shell 執行pdf加密程式
'
Public Sub tt2()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ActiveWorkbook.Sheets(1).Activate
    
    '目前檔案路徑
    nPath = ActiveWorkbook.Path
    '輸出資料夾名稱
    strFolderName = "output"
    
    '完整的輸出資料夾路徑
    outputFolderPath = nPath & Application.PathSeparator & strFolderName & Application.PathSeparator

    '判斷輸出資料夾是否存在
    strFolderExists = Dir(nPath & Application.PathSeparator & strFolderName, vbDirectory)
    
    If strFolderExists = "" Then
        '不存在則新增
        fso.CreateFolder nPath & Application.PathSeparator & strFolderName
    Else
        '存在則移除 再新增
        fso.DeleteFolder nPath & Application.PathSeparator & strFolderName, True 'True 強制刪除
        fso.CreateFolder nPath & Application.PathSeparator & strFolderName
    End If
    
    '將工作表轉存為PDF檔
    For i = 2 To Sheets.Count
        nName = Sheets(i).Name
        Sheets(i).Copy
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFolderPath & nName & ".pdf"
        ActiveWorkbook.Close False
    Next
    
    '讀取output資料夾的PDF 如果存在 回傳檔案名稱.副檔名
    pdfFile = Dir(outputFolderPath & "*.pdf")
        
    Dim fileArr() As String
    i = 0
    Do While pdfFile <> ""
        ReDim Preserve fileArr(i)
        fileArr(i) = outputFolderPath & pdfFile
        'Debug.Print outputFolderPath & pdfFile
        
        i = i + 1
        pdfFile = Dir()
    Loop
        
    'Debug.Print fileArr(0)
    '陣列上限(序位值)
    num = UBound(fileArr)
    
    Dim wsh As Object
    Set wsh = VBA.CreateObject("WScript.Shell")
    Dim waitOnReturn As Boolean: waitOnReturn = True
    Dim windowStyle As Integer: windowStyle = 0
    Dim errorCode As Long
    
    For i = 0 To num
    
        DoEvents
        sourceFilename = fileArr(i)
        setPassword = "123456"
        
        '透過WScript.Shell 執行pdf加密程式
        s = Chr(34) & Excel.ActiveWorkbook.Path & "\" & "0426_3.exe" & Chr(34) & Chr(32) & Chr(34) & sourceFilename & Chr(34) & Chr(32) & Chr(34) & setPassword & Chr(34)
            
        'Debug.Print s
        'Shell s
        
        errorCode = wsh.Run(s, windowStyle, waitOnReturn)
        
        If errorCode = 0 Then
'            MsgBox "Done! No error to report."
            Debug.Print "輸出:" & fileArr(i)
        Else
            MsgBox "Program exited with error code " & errorCode & "."
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

2024年4月26日 星期五

VBA / Excel VBA將檔案另存成PDF再使用自訂python程式加密PDF

VBA能否將excel轉成加密的PDF?

這個是在Line的excel社團看到的提問

其中的管理員提供了一個網路教學

這個教學是使用 Adobe Acrobat 物件

但是前提是必須先安裝付費版的 Adobe Acrobat

我後來想起之前彰化一整天有分享某個客製程式

其中有PDF加密功能，這個功能是在VBA執行他自己寫的python程式

經過自己土炮測試之後

我的構想，整體流程可以分成三部分

第一部分是在Excel透過VBA將工作表另存成PDF

第二部分是透過python程式加密PDF

第三部分是在Excel VBA執行 python程式

1.在Excel透過VBA將工作表另存成PDF

這是透過Excel的內建功能將工作表複製到新的工作簿

然後再存成PDF

流程大致如下

透過迴圈，使用工作簿功能ExportAsFixedForma逐一將工作表轉成PDF

1
2
3
4
5
6
 
    For i = 2 To Sheets.Count
        nName = Sheets(i).Name
        Sheets(i).Copy
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFolderPath & nName & ".pdf"
        ActiveWorkbook.Close False
    Next

 

2.透過python程式加密PDF

這裡的知識點是如何讓python接收外部參數

最簡單的方式 透過sys.argv來接收從cmd傳入的參數

1
2
3
4
5
6
7
8
9
 
import sys

def getArg(ar1, ar2):
    
    print()
    print('接收參數：', ar1,ar2)
    print()

getArg(sys.argv[1], sys.argv[2])

 

將以上的程式碼存成xx.py (xx是指隨意名稱)

然後在cmd執行 python xx.py 1 2 

就會輸出

接收參數：1 2

另一個知識點是如何加密PDF

可以利用套件 PyPDF2來處理

流程如下

#6~43 自訂一個函數

#8 第一個參數為檔案路徑

#9 第二個參數為密碼

#12 取出不含副檔名的檔案名稱

os.path.basename(pdf_path) 可以取出檔案路徑中最後一層，也就是檔案名稱.副檔名

#15 設定暫存檔的完整路徑

#17 設定用來寫入的檔案路徑

os.path.dirname(pdf_path) 可以取出最後一層之外的路徑，也就是檔案所在的目錄

因為加密後的檔案無法寫回原檔案，所以寫入另一個pdf

#21-23 使用套件 shutil複製原檔案產生新檔案

#25-27 使用PyPDF2的PdfReader物件來讀取PDF

 要先用open讀取檔案，再用PdfReader讀取PDF

#29-32 加密PDF

使用PyPDF2的PdfWriter物件的append_pages_from_reader獲取從PdfReader讀取的PDF

再用encrypt來加密

#34-36 將加密後的檔案寫入到用來輸出的檔案

因為產生一個空白的PDF還需要用別的套件生成

感覺太麻煩...

所以直接複製原本的檔案

#38-39 關閉利用open開啟的檔案

#41 刪除暫存檔

#42 關閉 PyPDF2的PdfReader、PdfReader物件

#43 如果之後封裝的程式要在背景執行，就不能有任何的print寫出

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
import os, sys
import shutil
from PyPDF2 import PdfReader 
from PyPDF2 import PdfWriter

def addPw(ar1, ar2):
    #print(ar1,ar2)
    pdf_path =ar1
    pswd=ar2
    
    #不含副檔名的檔案名稱
    fileName = os.path.basename(pdf_path).replace(".pdf", "")
    #print(fileName)
    #暫存檔 用來加密
    tempFile =os.path.dirname(pdf_path)+"\\"+ fileName + "_temp.pdf"
    #print(tempFile)
    #最後輸出的檔案  因為檔案加密之後 不能寫回原本的檔案
    newFile = os.path.dirname(pdf_path)+"\\"+ fileName +"_pw.pdf"
    #print(newFile)
    
    #複製產生檔案
    shutil.copyfile(pdf_path, tempFile)
    shutil.copyfile(pdf_path, newFile)
    
    #讀取暫存檔案
    in_file = open(tempFile, "r+b")
    in_pdf = PdfReader(in_file)
    
    #加密檔案
    out_pdf = PdfWriter()
    out_pdf.append_pages_from_reader(in_pdf)
    out_pdf.encrypt(pswd)
    
    #讀取用來存儲的檔案
    out_file = open(newFile, "wb")
    #寫出檔案
    out_pdf.write(out_file)
    
    #關閉open()開啟的檔案
    in_file.close()
    out_file.close()
    #刪除暫存檔
    os.remove(tempFile)
    #刪除PdfReader() PdfWriter()
    del in_pdf, out_pdf
    print("檔案加密完成")
    
addPw(sys.argv[1], sys.argv[2])

#addPw(r"C:\Users\edu\Desktop\PDF 轉檔 加密\output\臺北市.pdf","123456")

之後再用pyinstaller封裝成執行檔

3.在Excel VBA執行 python程式

#6-37 將工作表轉存成PDF

#39-51 讀取輸出資料夾內的所有PDF，將完整的檔案路徑寫入陣列中

#55-66 利用陣列進行迴圈

#59 是PDF密碼，之後可以再視需求來修改

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
Public Sub export_encrypt_PDF()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ActiveWorkbook.Sheets(1).Activate
    
    '目前檔案路徑
    nPath = ActiveWorkbook.Path
    '輸出資料夾名稱
    strFolderName = "output"
    
    '完整的輸出資料夾路徑
    outputFolderPath = nPath & Application.PathSeparator & strFolderName & Application.PathSeparator

    '判斷輸出資料夾是否存在
    strFolderExists = Dir(nPath & Application.PathSeparator & strFolderName, vbDirectory)
    
    If strFolderExists = "" Then
        '不存在則新增
        fso.CreateFolder nPath & Application.PathSeparator & strFolderName
    Else
        '存在則移除 再新增
        fso.DeleteFolder nPath & Application.PathSeparator & strFolderName, True 'True 強制刪除
        fso.CreateFolder nPath & Application.PathSeparator & strFolderName
    End If
    
    '將工作表轉存為PDF檔
    For i = 2 To Sheets.Count
        nName = Sheets(i).Name
        Sheets(i).Copy
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFolderPath & nName & ".pdf"
        ActiveWorkbook.Close False
    Next
    
    '讀取output資料夾的PDF 如果存在 回傳檔案名稱.副檔名
    pdfFile = Dir(outputFolderPath & "*.pdf")
        
    Dim fileArr() As String
    i = 0
    Do While pdfFile <> ""
        ReDim Preserve fileArr(i)
        fileArr(i) = outputFolderPath & pdfFile
        'Debug.Print outputFolderPath & pdfFile
        
        i = i + 1
        pdfFile = Dir()
    Loop
        
    'Debug.Print fileArr(0)
    '陣列上限(序位值)
    num = UBound(fileArr)
    
    For i = 0 To num
        sourceFilename = fileArr(i)
        setPassword = "123456"
        
        '透過cmd 執行pdf加密程式
        s = Chr(34) & Excel.ActiveWorkbook.Path & "\" & "0426_3.exe" & Chr(34) & Chr(32) & Chr(34) & sourceFilename & Chr(34) & Chr(32) & Chr(34) & setPassword & Chr(34)
            
        'Debug.Print s
        Shell s
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

參考資料

如何用pyinstaller将需要传参数的Python文件生成exe文件

Python:批次加密PDF文件

别再问我怎么Python打包成exe了！

2024年3月18日 星期一

VBA / 使用Excel VBA批次寄信 3

之前在VBA / 使用Excel VBA批次寄信 是修改 彰化一整天所寫的excel VBA程式
而這個版本是精簡程式，原理是一樣的，都是使用 CDO.Message物件
但是省去了設定頁面，呈現核心程式
只要知道STMP的設定資料
各個郵件伺服器應該都可以使用
本文以Gmail為範例

1.取得google應用程式密碼

google為了保護帳戶安全性
之前可以用低安全性設定來使用帳密連線SMTP
不過現在這個設定應該已經無法使用了
必須要設定並開啟兩步驟驗證 然後設定應用程式密碼，取代原本的帳號密碼
這組密碼是隨機產生的16位英文字母 換言之，就是改用隨機密碼取代原始密碼
而這組隨機密碼只能用在一種googgle應用程式
例如：當密碼第一次使用是用在gmail登入，之後就只能用在登入gmail，不能一組密碼用遍所有google功能
設定流程可以參考google文件說明，不知道之後會不會又改安全性設定

2.CDO.Message的參數設定

宣告Mail變數，使用晚期繫結的方式建立CDO.Message
再用Configuration.Fields.Item 設定參數 
  Dim Mail As Object
  Set Mail = CreateObject("CDO.Message")
  With Mail.Configuration.Fields
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl")= True
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")= "smtp.gmail.com"
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")= 465
      .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
      .Item("http://schemas.microsoft.com/cdo/configuration/sendusername")= "goohle帳號"
      .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword")= "google程式密碼"
      .Update
  End With

3.郵件設定

  With Mail
    .Subject = "VBA透過gmail寄mail"
    .From = "XXX@gmail.com"
    .To = "YYY@gmail.com"
    .CC = "ZZZ@gmail.com"
    .HTMLBody = "<h1>test 測試</h1>"
    .HTMLBodyPart.Charset = "utf-8"
    .Send
  End With
基本上，這樣程式就能夠使用Gmail帳號寄出信件了
其他的可以再依據需求來細部設定的
像是郵件內容，可以是純文字，也可以是Html格式
也可以增加附件檔案
要批量寄信就可以連結工作表以迴圈方式執行

2024年1月10日 星期三

VBA / Excel VBA 播放音檔

這個是臉書社群的問題
   
 研究了一下 我一開始的構想是用 cmd 執行播放程式，例如：windows media player 後來爬文知道 cmd 就是預設用 windows media player 來開啟音檔 而在VBA 可以用 Shell函數 或者引用  WScript.Shell物件來執行cmd 但是其實也可以直接用 Shell函數 或者 WScript.Shell物件執行 windows media player 不需要再調用 cmd來執行 windows media player 後來爬文發現另一個方式是調用winmm.dll 的sndPlaySoundA 或 PlaySoundA 以下分別說明這幾種方式的應用

Shell函數

{{CODE-4616}}
Windowstyle 常數 值 描述
vbHide 0 隱藏視窗，且將焦點傳遞給隱藏視窗。 VbHide 常數不適用於 Macintosh 平台。
vbNormalFocus 1 視窗有焦點並還原成原始的大小和位置。
vbMinimizedFocus 2 視窗顯示為具有焦點的圖示。
vbMaximizedFocus 3 視窗最大化且具有焦點。
vbNormalNoFocus 4 視窗還原為最近的大小和位置。 目前的作用中視窗仍維持作用中。
vbMinimizedNoFocus 6 視窗顯示為圖示。 目前的作用中視窗仍維持作用中。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Public Sub Shell_1()

    Dim RetVal '接收回傳執行情況
    
    RetVal = Shell("C:\Program Files (x86)\Windows Media Player\wmplayer.exe C:\windows\media\chord.wav", 0)
    
    If RetVal = 0 Then
        MsgBox "執行失敗"
    End If
    
End Sub
'
'
Public Sub Shell_2()

    Dim RetVal '接收回傳執行情況
    
    'cmd 語法
    'https://learn.microsoft.com/zh-tw/windows-server/administration/windows-commands/cmd
    RetVal = Shell("cmd.exe /S /C" & "C:\windows\media\chord.wav", 0)
  
    If RetVal = 0 Then
        MsgBox "執行失敗"
    End If
    
End Sub
 

WScript.Shell

語法 .Run(ByVal Command As String, [ByVal WindowStyle], [ByVal WaitOnReturn]) As Integer WindowStyle:跟Shell函數一樣 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
 
Public Sub ws1()

    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")
    
    'cmd 語法
    'https://learn.microsoft.com/zh-tw/windows-server/administration/windows-commands/cmd
    wsh.Run "cmd.exe /S /C" & "C:\windows\media\chord.wav", 0, 0

End Sub
'
'
Public Sub ws2()
    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")

    wsh.Run "wmplayer.exe C:\windows\media\chord.wav", 0, 0
End Sub
  無論是Shell函數 還是 WScript.Shell 只要是透過執行cmd來啟動 wmplayer.exe windows media player都會顯示視窗，無法隱藏，原因在於wmplayer.exe是被cmd啟動的

sndPlaySoundA

引用 winmm.dll 的sndPlaySoundA

參數1 pszSoundName

檔案路徑

參數2 uFlags

SND_ASYNC 異步/非同步 ，也可以用1，播放開始後即往下執行 SND_SYNC 同步，也可以用0，播放完了才往下執行 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
 
#If VBA7 Then
'Office 2013 & above
    #If Win64 Then
    'x64 host
    Private Declare PtrSafe Function sndPlaySound32 Lib "winmm.dll" _
    Alias "sndPlaySoundA" (ByVal lpszSoundName _
    As String, ByVal uFlags As LongPtr) As LongPtr
    #Else
    'x86 host
    Private Declare PtrSafe Function sndPlaySound32 Lib "winmm.dll" _
    Alias "sndPlaySoundA" (ByVal lpszSoundName _
    As String, ByVal uFlags As Long) As Long
    #End If
#Else
'Office 2010 & under:
    Private Declare Function sndPlaySound32 Lib "winmm.dll" _
    Alias "sndPlaySoundA" (ByVal lpszSoundName _
    As String, ByVal uFlags As Long) As Long
#End If
  
1
2
3
4
5
 
Sub SndPly()
 
    Call sndPlaySound32("C:\windows\media\chord.wav", 1)

End Sub
 

PlaySoundA

引用 winmm.dll 的PlaySoundA

參數1 lpszName

檔案路徑

參數2 hModule

必須是0

參數3 dwFlags

SND_ASYNC 異步/非同步 ，也可以用1，播放開始後即往下執行 SND_SYNC 同步，也可以用0，播放完了才往下執行 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
 
#If VBA7 Then
'Office 2013 & above
    #If Win64 Then
    'x64 host
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
    Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As LongPtr) As LongPtr
    #Else
    'x86 host
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
    Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
    #End If
#Else
'Office 2010 & under:
    Private Declare Function PlaySound Lib "winmm.dll" _
    Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If
  
1
2
3
4
5
 
Sub Ply()
 
    Call PlaySound("C:\windows\media\chord.wav", 0, 1)

End Sub
 

在工作簿的應用

自訂function beepFn()呼叫程序 
1
2
3
4
5
 
Function beeFn()
 
    Call sndPlaySound32("C:\windows\media\chord.wav", 1)

End Function
  在公式引用 自訂function beepFn() 
E2=IF(AND(C2<>"",C3 <>""),IF(C2=C3,"PASS","FAIL" & beepFn()),"")

缺點：因為是在公式裡引用，所以開啟檔案的時候會自動執行一次

備註1：關於程式路徑

cmd.exe 無論在Shell函數還是WScript.Shell 都可以省略路徑 而wmplayer.exe在WScript.Shell可以省略路徑，但是在Shell函數必須有完整路徑 這應該是跟環境參數的設定有關

備註2：關於同步/非同步

Shell函數只能非同步執行，也就是執行之後，不會等執行結束，程序就會立即接著執行後面的程式碼 WScript.Shell 、sndPlaySoundA、PlaySoundA，都可以設定同步/非同步

參考資料

VBS中WScript.Shell对象的run和exec的使用及区别 VBA关于声音的多种实现方法 

2024年1月8日 星期一

VBA / 使用Excel VBA插入圖檔

這個是在Line Excel VBA社群的問題 發問者提供了操作影片跟檔案，所以可以很好理解所遇到的問題
  
 原始檔案利用VBA寫了兩個程序   檔案一開始就存在的圖檔可以刪除 後來新增的圖檔卻不能刪除 研究了一下

發現這是圖檔類型(MsoShapeType)的問題

程式碼是利用 Sheet.Pictures.Insert()方法插入的圖片 圖檔類型是msoLinkedPicture 但是檔案一開始就存在的圖片應該是在工作表透過插入/圖片的方式 這樣圖檔類型會是msoPicture 從名稱就可以看出差別 前者是連結圖檔而已，所以當圖檔改變名稱或位置時 工作表就會讀不到圖檔

單就無法刪除圖檔的問題，只需要多一個條件就可以了

原始程式碼只有判別 msoPicture 
1
2
3
 
For Each a In ActiveSheet.Shapes
        If a.Type = msoPicture Then a.Delete
Next
  增加另一個 msoLinkedPicture的條件 
1
2
3
 
For Each a In ActiveSheet.Shapes
        If a.Type = msoPicture Or a.Type = msoLinkedPicture Then a.Delete
Next
 

但是比較好的方式是將匯入程式碼改為利用 Sheet.Shapes.AddPicture()

AddPicture (FileName、 LinkToFile、 SaveWithDocument、 Left、 Top、 Width、 Height) 而且這個方式也可以在參數設定時，設定成以連結方式讀取圖檔 原始程式碼 工作表的B欄儲存檔案名稱，而圖檔跟工作簿是放在同一個資料夾內 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
 
With Sheets("清冊")
	lRow = .[b65536].End(xlUp).Row
	For I = 2 To lRow
	On Error Resume Next
		'strFile = ThisWorkbook.Path & "\" & .Cells(i, 4) & ".jpg"
		strFile = ActiveWorkbook.Path & "\" & .Cells(I, 2) & ".jpg"
		Set oPic = .Pictures.Insert(strFile)
		With .Cells(I, 3)
			oPic.Top = .Top
			oPic.Left = .Left
			oPic.Width = 60
			oPic.Height = 70
		End With
		Set oPic = Nothing
	Next I
End With
  修改後的程式碼 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
 
With Sheets("清冊")
        lRow = .[b65536].End(xlUp).Row
        For I = 2 To lRow
        On Error Resume Next
            'strFile = ThisWorkbook.Path & "\" & .Cells(i, 4) & ".jpg"
'            strFile = "C:\Users\trico\Pictures" & "\" & .Cells(I, 2) & ".jpg"
            strFile = ActiveWorkbook.Path & "\" & .Cells(I, 2) & ".jpg"
            Set oPic = .Shapes.AddPicture(strFile, msoFalse, msoTrue, Cells(I, 3).Left + 2, Cells(I, 3).Top + 1, 120, 70)
            Set oPic = Nothing
        Next I
End With
  補充 當 LinkToFile 為msoFalse時， SaveWithDocument必須為msoTrue，插入的圖檔類型為 msoPicture 但是LinkToFile 為msoTrue時， SaveWithDocument無論是msoTrue或msoFalse，插入的圖檔類型都是 msoLinkedPicture

備註1

比較奇怪的點，同樣的圖片寬度設定，使用Shapes.AddPicture()插入的圖檔大小只有Pictures.Insert()的一半 所以在 Shapes.AddPicture()的寬度設定為Pictures.Insert()的2倍 (60→120) 不過後來發現在 Pictures.Insert()的寬度跟高度只要擇一設定就好了 現在的圖檔是會以高度等比例調整寬度，所以最終寬度其實不是60

備註2

Pictures.Insert()找不到官方的說明資料 找到的都是教學類或者論壇的使用範例 vba插入圖片問題 VBA help for a Macro (inserting picture from file)

2023年12月21日 星期四

VBA / 使用Excel VBA批次寄信 2

VBA / 使用Excel VBA批次寄信 是使用 CDO.Message物件 
 但其實也可以透過 Outlook.Application 來使用 Outlook功能 
 引用 Outlook.Application 建立 olMailItem 之後 
 後續的程式碼基本上 跟 VBA / 在Outlook使用VBA批次寄信  VBA / 在Outlook使用VBA批次寄信2 是相同的

excel工作表的格式

整體程式碼

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
 
Public Sub SendMail()
    Dim xOutApp As Object
    Dim xMailItem As Object
    
    Dim xLastRow As Long
    
    Dim erMsg As String '紀錄錯誤訊息
    Dim erNm As Integer '紀錄錯誤訊息筆數

    xLastRow = Sheets("mail").Range("B200").End(xlUp).Row
    
    '計數器 記錄實際寄出的郵件數量
    Dim send_Num As Integer
    send_Num = 0
    
    Set xOutApp = CreateObject("Outlook.Application")
    If xLastRow <> 1 Then
        For n = 2 To xLastRow
            Dim check_send As String '是否郵寄 字串形式
            check_send = Sheets("mail").Range("A" & n).Value
        
            If check_send <> "" Then
            
                    Dim delaysec As Integer
                    Dim SendDate As Date
                    
                    delaysec = Int((5 - 2 + 1) * Rnd() + 2)
                    SendDate = Now()
                    
        '            Debug.Print SendDate
                    
                    SendDate = DateAdd("s", delaysec, SendDate)
                    
        '            Debug.Print SendDate
                    
                    Set xMailItem = xOutApp.CreateItem(olMailItem)
                    
                    '內文格式
                    If Sheets("mail").Range("B" & n).Value = "txt" Then
                        With xMailItem
                            .Subject = Sheets("mail").Range("F" & n).Value '主旨
                            .To = Sheets("mail").Range("D" & n).Value      '收件人
                            .BodyFormat = olFormatPlain                    '內文編碼格式
                            .Body = Sheets("mail").Range("G" & n).Value    '內文
                        End With
                        
                    ElseIf Sheets("mail").Range("B" & n).Value = "html" Then
                    
                        With xMailItem
                            .Subject = Sheets("mail").Range("F" & n).Value  '主旨
                            .To = Sheets("mail").Range("D" & n).Value       '收件人
                            .BodyFormat = olFormatHTML                      '內文編碼格式
                            .HTMLBody = Sheets("mail").Range("G" & n).Value '內文
                        End With
                        
                    Else
                    
                        MsgBox "請確認內文編碼格式"
                        
                    End If
                    
                    '附加檔案1
                    If Sheets("mail").Range("H" & n).Value <> "" Then
                        xMailItem.Attachments.Add Sheets("mail").Range("H" & n).Value
                    End If
                    
                    '附加檔案2
                    If Sheets("mail").Range("I" & n).Value <> "" Then
                        xMailItem.Attachments.Add Sheets("mail").Range("I" & n).Value
                    End If
                      
                    'cc收件人
                    If Sheets("mail").Range("E" & n).Value <> "" Then
                        mail.CC = Sheets("mail").Range("E" & n).Value
                    End If
                    
                    'DeferredDeliveryTime 設定郵件的傳送日期及時間
                    xMailItem.DeferredDeliveryTime = SendDate
                    Debug.Print "編號：" & (n - 1) & "信件，寄出時間：" & SendDate
                    
        '               發生錯誤仍繼續執行
                    On Error Resume Next
                            
        '               當發生錯誤時 用 erMsg erNm 紀錄
                    If Err.Number <> 0 Then
                        erMsg = erMsg & "編號-" & (n - 1) & "-" & Err.Number & "/" & Err.Description & Chr(10)
                        erNm = erNm + 1
                    End If
                                
                    '寄出郵件
    '                xMailItem.Send
    
                    '顯示郵件視窗
                    xMailItem.Display
                    
                    Set xMailItem = Nothing
                    
                    '計數器+1
                    send_Num = send_Num + 1
            End If
        '       正常偵錯
                On Error GoTo 0
        Next
        
        '顯示錯誤的紀錄
        If erMsg <> "" Then
            Debug.Print erMsg
            'MsgBox erMsg
        End If
        
        Debug.Print "寄送完成，共寄出" & send_Num & "封，有" & erNm & "筆錯誤。"
            
        MsgBox "寄送完成，共寄出" & send_Num & "封，有" & erNm & "筆錯誤。"
    
    End If
    
    Set xOutApp = Nothing
    
End Sub
 

2023年11月1日 星期三

Excel / VLOOKUP / LOOKUP函數 (2024/2/26 修改)

Excel 多個條件，透過VLOOKUP / LOOKUP函數尋找一個值

其實就是把多個條件合併成一個條件

例如：

條件1+條件2→社區+戶型，回傳符合條件的價格

使用VLOOKUP 函數

H2=VLOOKUP(F2&G2,CHOOSE({1,2},$A$2:$A$10&$B$2:$B$10,$C$2:$C$10),2,0)

先利用CHOOSE函數-CHOOSE(index_num, value1, [value2], …)

如果 index_num 是個陣列，評估 CHOOSE 時會評估陣列中的每個數值

白話來說就是會得到所有評估值的陣列結果，並且會依據 index_num來組合陣列

所以這個例子會得到條件1( 社區)、條件二(戶型)，與對應結果(價格)形成的一個參照範圍{條件1&條件2 , 對應結果}

這樣就可以在VLOOKUP作為查閱值的參照範圍，取得傳回值

使用LOOKUP 函數

I2=LOOKUP(1,0/(A2&B2 = F2 &G2),C2)

J3=LOOKUP(1,0/($A$2:$A$10&$B$2:$B$10=F2&G2),$C$2:$C$10)

兩個公式的結構其實是一樣的，J3是陣列公式，所以除了比對值之外，都是範圍

這邊利用 LOOKUP如果找不到相同的目標值時，會返回小於目標值的最大值(不適用於 0/條件，而是區間查找，可以參考Lookup函數最經典的14種用法)

在第二個參數 0/條件

如果 條件 有符合值，會得到True，0/True=0

沒有符合值，會得到False，0/False會得到#N/A 的錯誤值

如果是陣列公式，就會得到所有的返回值，會是由0或 #N/A組合的陣列

後記

其實如果使用VBA，以程式方式來處理

可能會更直覺、直觀

Excel / INDEX-SMALL-IF-ROW 萬金油公式

最近在臉書跟Line上加入了幾個excel / excel VBA的社群

除了有很多喜好伸手牌的人會問問題之外

也有很多厲害的人會嘗試去解題

有時候看到所用的 excel函數結構非常複雜，真心覺得厲害

而且看到有巧思的運用函數公式，更會讓我想進一步了解公式是如何組合的

我有空的時候也會嘗試解決一些我看得懂的問題

(必須說，有部分的人連問題都說不清楚。也或者是我程度不夠，無法理解)

發現大多數的問題都是在既有資料中，尋找符合條件的目標

因此，多數的問題可以利用 INDEX-SMALL-IF-ROW 所謂的萬金油公式(用途很多)來處理

而在excel 2019之後的版本，可以用 Filter函數+Match函數來處理，並且自動溢位(也就是不用再按Ctrl+Shift+Enter，設定為陣列公式)

例如：以下資料

條件值：以 牌照號碼 為條件，取得符合條件的其他欄位資料，而這一個條件，會有多筆資料

利用 萬金油公式

E2=INDEX(工作表!A:A,SMALL(IF(工作表!$A$2:$A$435=$C$1,ROW($2:$435),“”),ROW(A1)))

F2=INDEX(工作表!D:D,SMALL(IF(工作表!$A$2:$A$435=$C$1,ROW($2:$435),4^10),ROW(A1)))

G2~I2也都是一樣的公式結構

公式說明：由內而外，由右至左來理解

IF函數 

透過條件 工作表!$A$2:$A$435=$C$1

為True時，取得在ROW($2:$435)範圍內相對位置的值(ROW())

為False時，則為空值(“”跟4^10的結果都是一樣)

最後會得到一個{True/False}的結果陣列

SMALL函數

要找出符合資料在IF陣列結果的位置，以這個資料表來說就會是列數，並配合 ROW(A1)下向拉動，會產生1、2、3….，可以得到第1個符合的值、 第2個符合的值

INDEX函數

利用SMALL函數得到的列數值，回傳對應的欄位值，例如： 某列的在工作表!A欄的資料

利用 Filter函數

E2=FILTER(INDEX(工作表!A2:O435,,MATCH(E$1,工作表!$A$1:$O$1,0)),工作表!$A$2:$A$435=$C$1,””)

F2=FILTER(INDEX(工作表!A2:O435,,MATCH(F$1,工作表!$A$1:$O$1,0)),工作表!$A$2:$A$435=$C$1,””)

G2~I2也都是一樣的公式結構

公式說明：由內而外，由右至左來理解

MATCH函數

取得符合條件(例如： F$1)在目標資料的相對位置，也就是欄位值

INDEX函數

這時候反而是透過MATCH值，取得資料範圍內的符合欄位的所有值

Filter函數

在INDEX函數取得的資料內，透過條件 工作表!$A$2:$A$435=$C$1，篩選出符合條件的值

後記

之後可以再透過一些排除錯誤值的公式，讓結果更乾淨

如果是多個條件，尋找一個值，可以用 VLOOKUP / LOOKUP，這也有很多應用的技巧

2023年4月16日 星期日

Excel / VBA進度條

如果程式執行的時間需要太久

加上執行時的excel有時候看起來像死當

如果有進度條的話，應該可以避免這種誤會

 

32位元的excel可以用mscomctl.ocx控制項的ProgressBar來製作

但是現在大多是用64位元的excel，所以這種方式的應用性不高了

不過可以改用表單的Label標籤的功能來產生相似的功能

1.首先新增一個表單，並加入Label

可以修改預設的表單與Label名稱

方便之後的程式碼使用

這裡是將表單命名為labelBar、Label命名為PB，width=430

這些都是在「屬性視窗」修改

2.撰寫程式碼

思路有2種

第1種是利用表單的Activate()事件

把要執行的程序寫在這邊

之後只要啟動表單即可

例如：

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
Sub UserForm_Activate()
    '狀態列歸零
    PB.Width = 0
    Call 刪除舊工作表
    '1.工作表名稱範圍
    r = Sheets(1).Range("A2").End(xlDown).Row
    For i = 2 To r
        '2.取得類股名稱
        x = Sheets(1).Cells(i, "A")
        y = Sheets(1).Cells(i, "B")
        '3.新增工作表並重新命名
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = x
        '下載資料
        Call 股市下載(y)
        PB.Width = (i - 1) * (400 / (r - 1))
        home.Repaint
    Next
    Sheets(1).Select
    home.Hide
End Sub

 

第2種是寫在執行程序中

這種方式要留意的是必須允許其他程序能夠同時執行

表單.show 必須加上0，表示vbModeless

不然正常的情況下執行表單，表單會在最上層，而且無法控制試算表與其他程序

表單.show 0

以下是土炮的程式碼

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Sub test()
 labelBar.Show 0
 
 labelBar.PB.Width = 0
 
 labelBar.Caption = "t1"
 Call t1
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t2"
 Call t2
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t3"
 Call t3
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t4"
 Call t4
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t5"
 Call t5
 Application.Wait (Now + TimeValue("0:00:03"))
 
 Unload labelBar
  
 MsgBox "執行完畢"

End Sub

Sub t1()

    labelBar.PB.Width = 430 * 0.2
    labelBar.Repaint
    
End Sub

Sub t2()

    labelBar.PB.Width = 430 * 0.4
    labelBar.Repaint
    
End Sub

Sub t3()

    labelBar.PB.Width = 430 * 0.6
    labelBar.Repaint
    
End Sub

Sub t4()

    labelBar.PB.Width = 430 * 0.8
    labelBar.Repaint
    
End Sub

Sub t5()

    labelBar.PB.Width = 430 * 1
    labelBar.Repaint
    
End Sub

 

備註：後來看之前的VBA練習，其實還有第3種方式：在表單內執行程序

也就是在表單設計功能選項或按鈕來執行程序

例如：

Sub 批次篩選(清單 As String, 欄位 As Integer)會接受表單傳來的參數

來處理篩選的流程，並且修改進度條的參數

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Sub 批次篩選(清單 As String, 欄位 As Integer)
    Call 批次刪除
    Application.ScreenUpdating = False
    r = Sheets("清單").Range(清單 & "2").End(xlDown).Row
    For i = 2 To r
        X = Sheets("清單").Cells(i, 清單)
        
        '1.游標放B1
        Range("B1").Select
        '2.篩選
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$L$2500").AutoFilter Field:=欄位, Criteria1:=X
        '3.複製
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        
        '4.新增工作表
        Sheets.Add After:=Sheets(Sheets.Count)
        '命名
        Sheets(Sheets.Count).Name = X
        
        '5.貼上
        Range("A1").Select
        ActiveSheet.Paste
        
        '6.自動調整欄寬
        Selection.Columns.AutoFit
        
        Range("A1").Select
        
        '7.切回原工作表
        Sheets(1).Select
        
        '8.取消篩選
        Selection.AutoFilter
        
        '9.切回到A1
        Range("A1").Select
        home.PB.Width = (i - 1) * 400 / (r - 1)
        home.lb01.Caption = "執行率" & Math.Round((i - 1) / (r - 1), 2) * 100 & "%"
        home.Repaint
    
        Application.StatusBar = i & "筆"
    Next
    Application.ScreenUpdating = True
End Sub

 

表單的程式碼：

表單開啟時的初始設定：將labe PB寬度設定為0，加入下拉式選單選項

按鈕CommandButton1被點選時，依據選單選項傳遞參數到 批次篩選()

而進度條也就會隨著修改

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
Sub CommandButton1_Click() 
	If cd01.Text = "業務" Then 
		Call 批次篩選("A", 3) 
	ElseIf cd01.Text = "產業別" Then 
		Call 批次篩選("B", 4) 
	ElseIf cd01.Text = "產品" Then 
		Call 批次篩選("C", 5) 
	ElseIf cd01.Text = "客戶名稱" Then 
		Call 批次篩選("D", 12) 
	End If 
End Sub

Sub UserForm_Initialize() 
	PB.Width = 0 
	cd01.AddItem "請選擇篩選類別" 
	cd01.AddItem "業務" 
	cd01.AddItem "產業別" 
	cd01.AddItem "產品" 
	cd01.AddItem "客戶名稱" 
End Sub

 

這樣就可以避免表單啟動時，其他程序無法執行的問題