pptのvbaについて調べたメモ

 pptのvbaについて調べたメモ

複数のグラフを選択してpptに貼り付けるのが遅いのを改善しようとして色々と調べています。

Excelで12個のグラフを選択して、pptにピクチャで貼り付けるのに4秒かかります。

デバイスに依存しないピクチャ(DIB)は2秒程度で早いのですが、vbaで設定がありません。

SVGも2秒くらいなのですが、今度は貼り付けた後のサイズ変更に時間がかかってしまいます。

SVG形式はメタファイルよりも高速で貼り付けられるし、拡大してもきれいで優秀なのですが、あまりwebに情報が載っていません。PasteSpecialのdatatypeは12 (ppPasteSVG)です。

pptのグラフィック処理が遅いのではないかと考えています。

エクセル側で図としてコピーなども試してみましたが遅かったです。

The Voyage of a neuromancer
PowerPointにはScreenUpdatingがない

https://neuromancer-sho.hatenablog.com/entry/20130308/1362743363

hiroshi akutsuの日記
vba【図としてコピーした画像をpower pointへ貼り付け時に変数に代入】

https://hakoniwahaniwa.hatenablog.com/entry/2014/12/16/101720

Excel vbaで複数グラフを選択する

 Excel vbaで複数グラフを選択する

直接この記事と関係ないけど、下記のvbaのリストがとても良いです。

Kunihito TOBITA Office (飛田国人)

Excel: VBA覚え書き　

http://www.ess.osakafu-u.ac.jp/human/tobita/2018/08/16/excel3/

'これが基本

ActiveSheet.Shapes.Range(Array("グラフ 1", "グラフ 2")).Select

'これはNG

a=Array("グラフ 1", "グラフ 2")

ActiveSheet.Shapes.Range(a).Select

'これはOK

Dim a() As Variant

a=Array("グラフ 1", "グラフ 2")

ActiveSheet.Shapes.Range(a).Select

'これもOK

ReDim a(0 To 1)

a=Array("グラフ 1", "グラフ 2")

ActiveSheet.Shapes.Range(a).Select

'これはNG

aa1 = "グラフ 1,グラフ 2"

buf2 = Split(aa1, ",")

ActiveSheet.Shapes.Range(buf2).Select

'Variant/Variantでないとダメみたい。

追記

詳しい理由はわからないけど配列に代入しておいて、Rangeのカッコの中でJoinしてsplitするといけるっぽい。

vbaでシート一覧とグラフ一覧を取得

 Excel vbaでシート一覧とグラフ一覧を取得する

実行するとアクティブシートの1行目にラベル、2行目以降に各シートのグラフ名を列挙します。

A列　Sheet Name　シート名

B列　Graph Name　グラフ名（カンマ区切り）

C列　paste1.txt（全部同じ）

D列　PageDown　1(全部同じ)

E列　Comment　シート名

Sub sht_get()

   

    Dim dt, cnt, buf, sh, g

    cnt = 2

   

    ReDim dt(1 To Worksheets.Count + 1, 1 To 5)

   

    dt(1, 1) = "Sheet Name"

    dt(1, 2) = "Graph Name"

    dt(1, 3) = "Paste"

    dt(1, 4) = "PageDown"

    dt(1, 5) = "Comment"

   

    For Each sh In ThisWorkbook.Sheets

        If sh.ChartObjects.Count = 0 Then GoTo skip_syori

       

        dt(cnt, 1) = sh.Name

       

        buf = ""

        For Each g In sh.ChartObjects

            buf = buf & "," & g.Name

        Next g

        dt(cnt, 2) = Mid(buf, 2)

        dt(cnt, 3) = "paste1.txt"

        dt(cnt, 4) = 1

        dt(cnt, 5) = sh.Name

        cnt = cnt + 1

skip_syori:

    Next sh

    Cells(1, 1).Resize(cnt - 1, 5) = dt

   

End Sub

pythonで近似式とR2を求める

Pythonを使って下記を行います。

・二次元配列(100ｘ2)の値を間引く
・二次元配列(10ｘ2)の値を第0列の値で昇順にソート
・二次元配列をx,yの散布図と考えて、1次、2次、5次の多項式近似で近似曲線を作成
・各近似式の決定係数R2を求める

numpyが必要

import numpy as np

arr = np.random.rand(100, 2)    # 100 x 2の配列の乱数

arr2=arr[::10]                  #1/10に間引く

arr3 = np.sort(arr2,axis=0)     #0番の列で昇順にソート

coe1 = np.polyfit(arr3[:,0], arr3[:,1], 1)  #1次多項式

coe2 = np.polyfit(arr3[:,0], arr3[:,1], 2)  #2次多項式

coe5 = np.polyfit(arr3[:,0], arr3[:,1], 5)  #3次多項式

fit1=np.poly1d(coe1)(arr3[:,0])

fit2=np.poly1d(coe2)(arr3[:,0])

fit5=np.poly1d(coe5)(arr3[:,0])

r2_1 = np.corrcoef(arr3[:,1], fit1)[0,1] ** 2   #yの値同士を入れる

r2_2 = np.corrcoef(arr3[:,1], fit2)[0,1] ** 2   #yの値同士を入れる

r2_5 = np.corrcoef(arr3[:,1], fit5)[0,1] ** 2   #yの値同士を入れる

print(r2_1,r2_2,r2_5)

 

＝＝＝＝＝＝＝＝＝

Pythonを使ってグラフを読み取ります。作りかけです。

・グラフの枠の座標を取得する
・グラフの枠内を白く塗りつぶす
・軸の数字と座標を認識する
グラフデータの読み込みや画像の座標からグラフの数値への変換は未実装です。

pillow、pyocr、Opencv、Tesseract、numpyが必要です。

import sys

import os

from PIL import Image

import pyocr

import cv2

import numpy as np

#Tesseractのインストール場所をOSに教える

tesseract_path = "C:\Program Files\Tesseract-OCR"

if tesseract_path not in os.environ["PATH"].split(os.pathsep):

    os.environ["PATH"] += os.pathsep + tesseract_path

#OCRエンジンを取得する

tools = pyocr.get_available_tools()

if len(tools) == 0:

    print("OCRエンジンが指定されていません")

    sys.exit(1)

else:

    tool = tools[0]

# 8ビット1チャンネルのグレースケールとして画像を読み込む

img_org = cv2.imread("sample.bmp", cv2.IMREAD_GRAYSCALE)

img=cv2.bitwise_not(img_org)    # 白黒反転　輪郭検出で白色の枠を検出するため、外枠が白になるように白黒反転

#輪郭検出　cv2.RETR_EXTERNAL　最外部の輪郭のみ検出　CHAIN_APPROX_TC89_L1：直線近似できる部分の輪郭点を省略

#contours[輪郭番号][点の番号][0][X座標, Y座標]

contours, hierarchy = cv2.findContours(img, cv2.RETR_EXTERNAL, cv2.CHAIN_APPROX_TC89_L1 )

# 画像表示用に入力画像をカラーデータに変換する

img_disp = cv2.cvtColor(img, cv2.COLOR_GRAY2BGR)

img_disp_org = cv2.cvtColor(img_org, cv2.COLOR_GRAY2BGR)

# 輪郭の点の描画

#contours[輪郭番号][点の番号][0][X座標, Y座標]

for i, contour in enumerate(contours):

    # 輪郭を描画　画像名、輪郭座標、輪郭番号、色、線幅（-1は塗りつぶし）

    cv2.drawContours(img_disp, contours, i, (255, 0, 0), 2)

    # 傾いていない外接する矩形領域

    x,y,w,h = cv2.boundingRect(contour)

    if w>100:       #幅100より大きい(グラフの外枠)のとき、orgのほうは白く塗りつぶし

        cv2.rectangle(img_disp,(x,y),(x+w-1,y+h-1),(0,255,0),2)

        cv2.rectangle(img_disp_org,(x,y),(x+w-1,y+h-1),(255,255,255),-1)    #白く塗りつぶす

       

#fileに書いて後ろでもう一度読み込んでいる。絶対もっと良い方法がある

cv2.imwrite('output.png', img_disp_org)

#画像の読み込み

file_path = "sample.bmp"

img = Image.open('output.png')      #ここはいつか改善する

img2 = img_disp_org                 #グラフ部を塗りつぶした画像

#文字と座標を読み取る

box_builder = pyocr.builders.WordBoxBuilder(tesseract_layout=6)     #6が最適かは不明

text_position = tool.image_to_string(img,lang="eng",builder=box_builder)

#取得した座標と文字を出力、画像に枠を書き込む

for res in text_position:

    print(res.content)

    print(res.position)

    cv2.rectangle(img2,res.position[0],res.position[1],(0,0,255),2)

#検出した軸ラベルの座標からx,y軸それぞれのグラフ範囲を推定する処理を入れる　未

#別途グラフの系列データを認識して、グラフ範囲に変換する　未

#四角を書き込んだ画像を表示

cv2.imshow("image",img2)

cv2.waitKey(0)

VBAで系列を追加する jpegをpptスライドに貼る pythonでs2pファイルをde-embedする

Chat-GPTに教えてもらいました。あいつ凄いな。

vbaで散布図に系列を追加する
系列の順序を指定したい場合、非表示の系列(.IsFiltered = True)があるとPlotOrderが機能しないので.Formulaプロパティで順序を指定することにしました。Formulaプロパティの操作はエラーがおきやすいので注意。withを使ったほうが速いらしいのでwithを入れました。

Sub AddNewSeries3()

    Dim myChart As Chart

    Set myChart = ActiveSheet.ChartObjects("Chart 1").Chart

   

    Dim mySeries As Series

    Set mySeries = myChart.SeriesCollection.NewSeries

   

    With mySeries

        'Name,X,Y,Order

        .Formula = "=SERIES(Sheet3!$A$1,Sheet3!$A$2:$A$6,Sheet3!$B$2:$B$6,3)"

       

        'set the marker type and size

        .MarkerStyle = xlMarkerStyleCircle

        .MarkerSize = 8

       

        'set the line type and color

        .ChartType = xlXYScatterLines

        .Format.Line.Weight = 2

        .Format.Line.ForeColor.RGB = RGB(255, 0, 0)

    End With

End Sub

pptでフォルダ内のjpegファイルをpptの各ページに貼り付ける。

Sub InsertImagesToSlides()

    Dim imagePath As String

    Dim imageFiles() As String

    Dim i As Integer

    Dim slide As Slide

    Dim slideIndex As Integer

   

    ' Specify the path to the folder containing the JPEG files

    imagePath = "C:\Path\To\Your\Images\Folder\"

   

    ' Collect all JPEG files in the specified folder

    imageFiles = GetFilesInFolder(imagePath, "*.jpg")

   

    ' Create a new PowerPoint presentation

    Dim pptApp As Object

    Set pptApp = CreateObject("PowerPoint.Application")

    pptApp.Visible = True

    Dim pptPres As Object

    Set pptPres = pptApp.Presentations.Add

   

    ' Loop through the image files and insert each one into a new slide

    slideIndex = 1

    For i = LBound(imageFiles) To UBound(imageFiles)

        Set slide = pptPres.Slides.Add(slideIndex, 12) ' 12 represents the slide layout (blank slide)

        slide.Shapes.AddPicture FileName:=imagePath & imageFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=pptPres.PageSetup.SlideWidth, Height:=pptPres.PageSetup.SlideHeight

        slideIndex = slideIndex + 1

    Next i

   

    ' Clean up

    Set slide = Nothing

    Set pptPres = Nothing

    Set pptApp = Nothing

   

    MsgBox "Images inserted successfully!"

End Sub

Function GetFilesInFolder(folderPath As String, filePattern As String) As String()

    Dim files() As String

    Dim file As String

    Dim i As Integer

   

    file = Dir(folderPath & filePattern)

    i = 0

   

    Do While file <> ""

        ReDim Preserve files(i)

        files(i) = file

        i = i + 1

        file = Dir

    Loop

   

    GetFilesInFolder = files

End Function

pythonでサブフォルダ[rename]内のすべてのファイルについて、ファイル名先頭の数字(アンダーバー区切り)を3桁で0埋めしてリネーム

import os, re

def main():

    for f in os.listdir("resize"):

 

        ff=f.split('_',1)

        ff[0]='{0:03d}'.format(int(ff[0]))

        f2="_".join(ff)

        of = "resize/" + f

        nf2="resize/" + f2

        try:

            os.rename(of, nf2)

            print(of, " >> ", nf2)

        except:

            print(u"リネーム前と後が同じです。", nf2)

if __name__ == '__main__':

    main()

pythonでtouchstone file をde-embedする。
ドラッグアンドドロップや引数での処理に対応したいけどpathの処理がうまく理解できず、残課題です。

import skrf as rf

from os import path

mypath =path.dirname(__file__)

evb1 = rf.Network(path.join(mypath,"a.s2p"))

evb2 = rf.Network(path.join(mypath,"b.s2p"))

dut = rf.Network(path.join(mypath,"dut.s2p"))

# evb2.renumber([0,1],[1,0])

evb1_intp=evb1.interpolate(dut.frequency)

evb2_intp=evb2.interpolate(dut.frequency)

dut_de=evb1_intp.inv ** dut ** evb2_intp.inv

dut_de.write_touchstone(path.join(mypath,"dut_de-embed3.s2p"))

VBAでcsvファイルを開く

 VBAでcsvファイルを開く

QueryTableで開くと速いという記事を見つけたので試してみた。別に早くない。区切り文字が決まっているならline inputで1行づつ読んでsplitして配列に入れて貼り付けるほうが早い。

sub open_csv()

    Dim msh, fname

    fname ="C:\local\test.csv"

    msh ="test"

    Sheets.Add(After:=Sheets(Sheets.Count)).Name  = msh

    Set ws = Sheets(msh)

    Set qt = ws.QueryTables.Add(Connection:="TEXT;" & fname, Destination:=ws.Range("A1")) 

    With qt

        .TextFilePlatform = 932          ' 文字コードを指定

        .TextFileParseType = xlDelimited ' 区切り文字の形式

        .TextFileCommaDelimiter = True   ' カンマ区切り

        .RefreshStyle = xlOverwriteCells ' セルに上書き

        .Refresh                         ' データを表示

        .Delete                          ' CSV との接続を解除

    End With

End Sub

VBAで複素数の計算とSparameterの変換

Excel VBAで複素数の計算

vbaで複素数を扱う場合、WorkSheetFunctionを使うより自分で関数を作ったほうがかなり速い。

'複素数の型宣言

Type Complex

    re As Double

    im As Double

End Type

'VBA 複素数の定義

Function CPX(a As Double, b As Double) As Complex

    CPX.re = a

    CPX.im = b

End Function

Function CPXR(a As Complex) As Double

    CPXR = a.re

End Function

Function CPXI(a As Complex) As Double

    CPXI = a.im

End Function

Function CPXABS(z As Complex) As Double

    CPXABS = Sqr(z.re ^ 2 + z.im ^ 2)

End Function

Function CPXSUM(z1 As Complex, z2 As Complex) As Complex

    Dim z As Complex

    z.re = z1.re + z2.re

    z.im = z1.im + z2.im

    CPXSUM = z

End Function

Function CPXSUB(z1 As Complex, z2 As Complex) As Complex

    Dim z As Complex

    z.re = z1.re - z2.re

    z.im = z1.im - z2.im

    CPXSUB = z

End Function

Function CPXPRD(z1 As Complex, z2 As Complex) As Complex

    Dim z As Complex

    z.re = z1.re * z2.re - z1.im * z2.im

    z.im = z1.re * z2.im + z1.im * z2.re

    CPXPRD = z

End Function

Function CPXDIV(z1 As Complex, z2 As Complex) As Complex

    Dim z As Complex

    Dim k As Double

    k = z2.re ^ 2 + z2.im ^ 2

    z.re = (z1.re * z2.re + z1.im * z2.im) / k

    z.im = (z1.im * z2.re - z1.re * z2.im) / k

    CPXDIV = z

End Function

vbaでSパラメータを処理するときのフォーマット変換とk値やMAGの算出

Function RItoDB(r, i)

    RItoDB = 20 * Log(Sqr((r ^ 2) + (i ^ 2))) / Log(10)

End Function

Function RItoMAG(r, i)

    RItoMAG = Sqr((r ^ 2) + (i ^ 2))

End Function

Function RItoANG(r, i)

    RItoANG = WorksheetFunction.Degrees(WorksheetFunction.Atan2(r, i))

End Function

Function LINtoDB(mag)

    LINtoDB = 20 * Log(mag) / Log(10)

End Function

s11 = CPX(S_11R, S_11I)

s21 = CPX(S_21R, S_21I)

s12 = CPX(S_12R, S_12I)

s22 = CPX(S_22R, S_22I)

' calculation MAG k

d = CPXABS(CPXSUB(CPXPRD(s11, s22), CPXPRD(s12, s21)))

bb = (1 + CPXABS(s11) * CPXABS(s11) - CPXABS(s22) * CPXABS(s22) - d * d)

k = (1 - CPXABS(s11) * CPXABS(s11) - CPXABS(s22) * CPXABS(s22) + d * d) / (2 * CPXABS(CPXPRD(s12, s21)))

If (1 - CPXABS(s11)) <> 0 Then vswr1 = (1 + CPXABS(s11)) / (1 - CPXABS(s11))

If (1 - CPXABS(s22)) <> 0 Then vswr2 = (1 + CPXABS(s22)) / (1 - CPXABS(s22))

msg = 10 * (Log(CPXABS(s21) / CPXABS(s12)) / Log(10))

If bb > 0 Then mag = msg - 10 * (Log(k * 1 + Sqr(k * k - 1))) / Log(10)