530 lines
17 KiB
QBasic
530 lines
17 KiB
QBasic
Attribute VB_Name = "Module1"
|
||
Option Explicit
|
||
|
||
'******************************************************************************
|
||
'シート名
|
||
Public shMSSdata As String
|
||
Public shMSSattach As String
|
||
Public shMSSlist1 As String
|
||
Public shMSSlist2 As String
|
||
|
||
Public shMSSattach2 As String
|
||
Public shMSSlist3 As String
|
||
|
||
Public thList As String
|
||
|
||
'共通変数F
|
||
Public keiyakuCode As String
|
||
Public workFolder As String
|
||
Public customerName As String
|
||
Public currentDirPath As String
|
||
Public apiKey As String
|
||
Public baseURL As String
|
||
|
||
'組織リスト
|
||
Public DeptsList As New Dictionary
|
||
|
||
|
||
'フォルダ名に使用できない文字一覧
|
||
Public invalidChars As String
|
||
|
||
'******************************************************************************
|
||
Function init()
|
||
'パブリック変数に値を格納
|
||
shMSSdata = "MSSデータ"
|
||
shMSSattach = "MSS添付"
|
||
shMSSlist1 = "MSSデータ一覧"
|
||
shMSSlist2 = "MSSリスト"
|
||
|
||
shMSSattach2 = "お客様データ添付"
|
||
shMSSlist3 = "お客様データリスト"
|
||
|
||
thList = "WF追加変更申請"
|
||
|
||
|
||
currentDirPath = Application.ThisWorkbook.Path
|
||
invalidChars = "<>/\\:*?" & Chr(34) & Chr(39) & Chr(0) & Chr(60) & Chr(62) & Chr(42) & Chr(124) & Chr(58) & Chr(160)
|
||
|
||
'Pleasanter API KEY
|
||
apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d"
|
||
baseURL = "https://nextoffice.Next-hd.co.jp"
|
||
|
||
'ダウンロードファイルを保存するフォルダのパスを作成
|
||
Dim class200 As String
|
||
class200 = Range("レコード名").value
|
||
If class200 <> "" Then
|
||
'フォルダ名に使えない文字を削除
|
||
Dim i As Integer
|
||
For i = 1 To Len(invalidChars)
|
||
class200 = Replace(class200, Mid(invalidChars, i, 1), "")
|
||
Next i
|
||
'スペースをアンダースコアに置き換え
|
||
class200 = Replace(class200, " ", "")
|
||
class200 = Replace(class200, " ", "")
|
||
workFolder = class200
|
||
Else
|
||
workFolder = ""
|
||
End If
|
||
|
||
End Function
|
||
|
||
|
||
Sub getFileDownloadList1()
|
||
'Debug.Print ">>> 指定された添付ファイルを一括ダウンロード 開始"
|
||
Call init
|
||
|
||
Dim listCount As Long
|
||
Dim fileCount As Long
|
||
|
||
Dim hyplink As Hyperlink
|
||
|
||
'ダウンロードログ欄のクリア
|
||
Dim g1 As Long
|
||
g1 = 12
|
||
Dim g2 As Long
|
||
g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row
|
||
If g2 >= g1 Then
|
||
With Worksheets(shMSSattach).Range(Worksheets(shMSSattach).Cells(g1, 8), Worksheets(shMSSattach).Cells(g2, 8))
|
||
.ClearContents
|
||
.Hyperlinks.Delete
|
||
.Font.Color = RGB(0, 0, 0)
|
||
.Font.Underline = False
|
||
.Font.Bold = False
|
||
End With
|
||
End If
|
||
|
||
'クリア
|
||
With Worksheets(shMSSattach).Range("H9")
|
||
.ClearContents
|
||
.Hyperlinks.Delete
|
||
.Font.Color = RGB(0, 0, 0)
|
||
.Font.Underline = False
|
||
.Font.Bold = False
|
||
End With
|
||
|
||
Worksheets(shMSSattach).Cells(g1, 8).value = "---ダウンロード開始---"
|
||
|
||
listCount = Worksheets(shMSSattach).Cells(Rows.count, 1).End(xlUp).Row
|
||
Dim i As Long
|
||
'添付ファイルシートより、DL指定されている項目からGuidリストを取得
|
||
For i = 2 To listCount
|
||
If Worksheets(shMSSattach).Cells(i, 6) = 1 Then
|
||
If Worksheets(shMSSattach).Cells(i, 5) > 0 Then
|
||
'**********************************
|
||
'顧客別フォルダが存在するか確認
|
||
Dim fso As Object
|
||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||
|
||
If Not fso.FolderExists(currentDirPath & "\" & workFolder) Then
|
||
'ない場合はフォルダを作成
|
||
fso.CreateFolder (currentDirPath & "\" & workFolder)
|
||
|
||
End If
|
||
|
||
'保存ディレクトのリンク作成
|
||
Worksheets(shMSSattach).Range("H9").value = workFolder
|
||
Set hyplink = ActiveSheet.Hyperlinks.Add( _
|
||
Anchor:=Worksheets(shMSSattach).Range("H9"), _
|
||
Address:=workFolder)
|
||
|
||
'保存するディレクトリ確認
|
||
Dim saveFolderPath As String
|
||
Dim docName As String
|
||
Dim docNumber As String
|
||
docName = Worksheets(shMSSattach).Cells(i, 2).value '項目の名前
|
||
docNumber = Worksheets(shMSSattach).Cells(i, 1) '項目の番号
|
||
|
||
Dim charCount As Integer
|
||
For charCount = 1 To Len(invalidChars)
|
||
docName = Replace(docName, Mid(invalidChars, charCount, 1), "")
|
||
Next charCount
|
||
|
||
saveFolderPath = currentDirPath & "\" & workFolder & "\" & docNumber & "." & docName
|
||
|
||
'項目名フォルダが存在するか確認
|
||
If Not fso.FolderExists(saveFolderPath) Then
|
||
'ない場合はフォルダを作成
|
||
fso.CreateFolder (saveFolderPath)
|
||
End If
|
||
|
||
Dim j As Long
|
||
j = Worksheets(shMSSattach).Cells(i, 4) '項目の列座標
|
||
fileCount = Worksheets(shMSSattach).Cells(Rows.count, j).End(xlUp).Row 'ファイルGuidリストの末尾行座標
|
||
|
||
'取得したGuidリストを元にダウンロード開始
|
||
Dim k As Long
|
||
|
||
|
||
For k = 4 To fileCount
|
||
Dim guid As String
|
||
Dim fileName As String
|
||
fileName = Worksheets(shMSSattach).Cells(k, j + 1).value
|
||
guid = Worksheets(shMSSattach).Cells(k, j).value
|
||
'Debug.Print "ファイルDL: " & fileName
|
||
|
||
'ダウンロード処理
|
||
Dim result As Boolean
|
||
result = getAttachmentsFile(guid, saveFolderPath)
|
||
|
||
'ダウンロード履歴保存
|
||
If result = True Then
|
||
g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row + 1
|
||
Worksheets(shMSSattach).Cells(g2, 8).value = docNumber & "." & docName & "\" & fileName
|
||
Set hyplink = ActiveSheet.Hyperlinks.Add( _
|
||
Anchor:=Worksheets(shMSSattach).Cells(g2, 8), _
|
||
Address:=workFolder & "\" & Worksheets(shMSSattach).Cells(g2, 8).value)
|
||
End If
|
||
|
||
Next k
|
||
End If
|
||
End If
|
||
Next i
|
||
|
||
g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row + 1
|
||
Worksheets(shMSSattach).Cells(g2, 8).value = "---ダウンロード終了---"
|
||
|
||
'Debug.Print "<<< 指定された添付ファイルを一括ダウンロード 終了"
|
||
|
||
End Sub
|
||
|
||
|
||
Sub getFileDownloadList2()
|
||
'Debug.Print ">>> 指定されたお客様データ添付ファイルを一括ダウンロード 開始"
|
||
Call init
|
||
|
||
Dim listCount As Long
|
||
Dim fileCount As Long
|
||
|
||
Dim hyplink As Hyperlink
|
||
|
||
|
||
'ダウンロードログ欄のクリア
|
||
Dim g1 As Long
|
||
g1 = 13
|
||
Dim g2 As Long
|
||
g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row
|
||
If g2 >= g1 Then
|
||
With Worksheets(shMSSattach2).Range(Worksheets(shMSSattach2).Cells(g1, 2), Worksheets(shMSSattach2).Cells(g2, 2))
|
||
.ClearContents
|
||
.Hyperlinks.Delete
|
||
.Font.Color = RGB(0, 0, 0)
|
||
.Font.Underline = False
|
||
.Font.Bold = False
|
||
End With
|
||
End If
|
||
|
||
'保存フォルダリンク クリア
|
||
With Worksheets(shMSSattach2).Range("B10")
|
||
.ClearContents
|
||
.Hyperlinks.Delete
|
||
.Font.Color = RGB(0, 0, 0)
|
||
.Font.Underline = False
|
||
.Font.Bold = False
|
||
End With
|
||
|
||
Worksheets(shMSSattach2).Cells(g1, 2).value = "---ダウンロード開始---"
|
||
|
||
listCount = Worksheets(shMSSlist3).Cells(Rows.count, 3).End(xlUp).Row
|
||
Dim i As Long
|
||
'お客様データリストシートより、DL指定されている項目からGuidリストを取得
|
||
For i = 4 To listCount
|
||
If Worksheets(shMSSlist3).Cells(i, 6) = 1 Then
|
||
If Worksheets(shMSSlist3).Cells(i, 5) > 0 Then
|
||
'**********************************
|
||
'顧客別フォルダが存在するか確認
|
||
Dim fso As Object
|
||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||
|
||
If Not fso.FolderExists(currentDirPath & "\" & workFolder) Then
|
||
'ない場合はフォルダを作成
|
||
fso.CreateFolder (currentDirPath & "\" & workFolder)
|
||
|
||
End If
|
||
|
||
'保存フォルダリンク リンク作成
|
||
Worksheets(shMSSattach2).Range("B10").value = workFolder
|
||
Set hyplink = ActiveSheet.Hyperlinks.Add( _
|
||
Anchor:=Worksheets(shMSSattach2).Range("B10"), _
|
||
Address:=workFolder)
|
||
|
||
'保存するディレクトリ確認
|
||
Dim saveFolderPath As String
|
||
Dim docName As String
|
||
Dim docNumber As String
|
||
docName = Worksheets(shMSSlist3).Cells(i, 2).value '項目の名前
|
||
docNumber = Worksheets(shMSSlist3).Cells(i, 1) '項目の番号
|
||
|
||
Dim charCount As Integer
|
||
For charCount = 1 To Len(invalidChars)
|
||
docName = Replace(docName, Mid(invalidChars, charCount, 1), "")
|
||
Next charCount
|
||
|
||
saveFolderPath = currentDirPath & "\" & workFolder & "\" & docNumber & "." & docName
|
||
|
||
'項目名フォルダが存在するか確認
|
||
If Not fso.FolderExists(saveFolderPath) Then
|
||
'ない場合はフォルダを作成
|
||
fso.CreateFolder (saveFolderPath)
|
||
End If
|
||
|
||
Dim j As Long
|
||
j = Worksheets(shMSSlist3).Cells(i, 4) '項目の列座標
|
||
fileCount = Worksheets(shMSSlist3).Cells(Rows.count, j).End(xlUp).Row 'ファイルGuidリストの末尾行座標
|
||
|
||
'取得したGuidリストを元にダウンロード開始
|
||
Dim k As Long
|
||
|
||
|
||
For k = 4 To fileCount
|
||
Dim guid As String
|
||
Dim fileName As String
|
||
fileName = Worksheets(shMSSlist3).Cells(k, j + 1).value
|
||
guid = Worksheets(shMSSlist3).Cells(k, j).value
|
||
'Debug.Print "ファイルDL: " & fileName
|
||
|
||
'ダウンロード処理
|
||
Dim result As Boolean
|
||
result = getAttachmentsFile(guid, saveFolderPath)
|
||
|
||
'ダウンロード履歴保存
|
||
If result = True Then
|
||
g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + 1
|
||
Worksheets(shMSSattach2).Cells(g2, 2).value = docNumber & "." & docName & "\" & fileName
|
||
Set hyplink = ActiveSheet.Hyperlinks.Add( _
|
||
Anchor:=Worksheets(shMSSattach2).Cells(g2, 2), _
|
||
Address:=workFolder & "\" & Worksheets(shMSSattach2).Cells(g2, 2).value)
|
||
End If
|
||
|
||
Next k
|
||
End If
|
||
End If
|
||
Next i
|
||
|
||
g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + 1
|
||
Worksheets(shMSSattach2).Cells(g2, 2).value = "---ダウンロード終了---"
|
||
|
||
'Debug.Print "<<< 指定されたお客様データ添付ファイルを一括ダウンロード 終了"
|
||
End Sub
|
||
|
||
|
||
'プリザンターのユーザー情報一覧取得
|
||
Sub getPleasanterUsers()
|
||
Application.ScreenUpdating = False '画面更新停止
|
||
Application.Calculation = xlManual '自動計算停止
|
||
'Debug.Print ">>> プリザンターのユーザー情報一覧取得 開始"
|
||
|
||
Dim sh As Worksheet
|
||
Set sh = Worksheets("マスターデータ")
|
||
sh.ListObjects("社員リスト").DataBodyRange.Delete
|
||
sh.ListObjects("組織リスト").DataBodyRange.Delete
|
||
|
||
Call init
|
||
|
||
Call getPleasanterDeptsRequest(0)
|
||
Call getPleasanterUsersRequest(0)
|
||
|
||
Application.Calculation = xlAutomatic '自動計算開始
|
||
Application.ScreenUpdating = True '画面更新開始
|
||
'Debug.Print "<<< プリザンターのユーザー情報一覧取得 終了"
|
||
End Sub
|
||
|
||
Function getPleasanterUsersRequest(offset)
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
'リクエストURL
|
||
apiUrl = baseURL & "/pleasanter/api/users/"
|
||
apiUrlParam = "Get"
|
||
|
||
'ヘッダ
|
||
Dim apiHeaders As New Dictionary
|
||
apiHeaders.Add "Content-Type", "application/json;charset=utf-8"
|
||
|
||
'リクエストデータ
|
||
Dim apiBody As New Dictionary
|
||
apiBody.Add "ApiVersion", "1.1"
|
||
apiBody.Add "ApiKey", apiKey
|
||
apiBody.Add "Offset", offset
|
||
|
||
'Filter変数
|
||
Dim colSorter As New Dictionary
|
||
colSorter.Add "UserId", "asc"
|
||
|
||
'View変数
|
||
Dim view As New Dictionary
|
||
view.Add "ColumnSorterHash", colSorter
|
||
apiBody.Add "View", view
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
'正常に取得できたらシートへ書き込み
|
||
'Call exportToSheetData(res)
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("TotalCount"))
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("PageSize"))
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("Offset"))
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("Data").count)
|
||
'Debug.Print "----- 取得成功"
|
||
|
||
Call exportUsersList(res)
|
||
|
||
End If
|
||
|
||
'200以上の場合は再実行
|
||
If res("Response")("PageSize") + res("Response")("Offset") < res("Response")("TotalCount") Then
|
||
Call getPleasanterUsersRequest(offset + 200)
|
||
End If
|
||
|
||
|
||
End Function
|
||
|
||
'マスターデータシートの社員リストテーブルを更新
|
||
Function exportUsersList(res)
|
||
Dim value
|
||
Dim N As Long
|
||
Dim sh As Worksheet
|
||
Set sh = Worksheets("マスターデータ")
|
||
|
||
For Each value In res("Response")("Data")
|
||
'Debug.Print value("UserId") & " " & value("LoginId") & " " & value("Name")
|
||
|
||
sh.ListObjects("社員リスト").ListRows.Add
|
||
N = sh.ListObjects("社員リスト").ListRows.count
|
||
With sh.ListObjects("社員リスト").ListRows(N)
|
||
.Range(1) = value("UserId")
|
||
.Range(2) = value("LoginId")
|
||
.Range(3) = value("Name")
|
||
.Range(4) = value("DeptCode")
|
||
.Range(5) = DeptsList(value("DeptCode"))
|
||
.Range(6) = ""
|
||
End With
|
||
|
||
Next value
|
||
|
||
End Function
|
||
|
||
Function getPleasanterDeptsRequest(offset)
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
'リクエストURL
|
||
apiUrl = baseURL & "/pleasanter/api/depts/"
|
||
apiUrlParam = "Get"
|
||
|
||
'ヘッダ
|
||
Dim apiHeaders As New Dictionary
|
||
apiHeaders.Add "Content-Type", "application/json;charset=utf-8"
|
||
|
||
'リクエストデータ
|
||
Dim apiBody As New Dictionary
|
||
apiBody.Add "ApiVersion", "1.1"
|
||
apiBody.Add "ApiKey", apiKey
|
||
apiBody.Add "Offset", offset
|
||
|
||
'Filter変数
|
||
Dim colSorter As New Dictionary
|
||
colSorter.Add "DeptId", "asc"
|
||
|
||
'View変数
|
||
Dim view As New Dictionary
|
||
view.Add "ColumnSorterHash", colSorter
|
||
apiBody.Add "View", view
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
'正常に取得できたらシートへ書き込み
|
||
'Call exportToSheetData(res)
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("TotalCount"))
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("PageSize"))
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("Offset"))
|
||
'Debug.Print JsonConverter.ConvertToJson(res("Response")("Data").count)
|
||
'Debug.Print "----- 取得成功"
|
||
|
||
Call exportDeptsList(res)
|
||
|
||
End If
|
||
|
||
'200以上の場合は再実行
|
||
If res("Response")("PageSize") + res("Response")("Offset") < res("Response")("TotalCount") Then
|
||
Call getPleasanterDeptsRequest(offset + 200)
|
||
End If
|
||
|
||
|
||
End Function
|
||
|
||
'マスターデータシートの組織リストを更新
|
||
Function exportDeptsList(res)
|
||
Dim value
|
||
Dim N As Long
|
||
Dim sh As Worksheet
|
||
Set sh = Worksheets("マスターデータ")
|
||
|
||
For Each value In res("Response")("Data")
|
||
DeptsList.Add value("DeptCode"), value("DeptName")
|
||
|
||
sh.ListObjects("組織リスト").ListRows.Add
|
||
N = sh.ListObjects("組織リスト").ListRows.count
|
||
With sh.ListObjects("組織リスト").ListRows(N)
|
||
.Range(1) = value("DeptId")
|
||
.Range(2) = value("DeptCode")
|
||
.Range(3) = value("DeptName")
|
||
.Range(4) = value("Body")
|
||
End With
|
||
|
||
Next value
|
||
|
||
End Function
|
||
|
||
Sub SheetToPdfSave1()
|
||
Call SheetToPdfSave("覚書", "覚書【閲覧専用】")
|
||
End Sub
|
||
|
||
Sub SheetToPdfSave2()
|
||
Call SheetToPdfSave("粗利益確認書(設計契約)", "粗利益確認書(設計契約)【閲覧専用】")
|
||
End Sub
|
||
|
||
Sub SheetToPdfSave3()
|
||
Call SheetToPdfSave("粗利益確認書(本契約)", "粗利益確認書(本契約)【閲覧専用】")
|
||
End Sub
|
||
|
||
|
||
'指定したシートを名前をつけてPDF保存
|
||
Function SheetToPdfSave(shName, fileName)
|
||
|
||
Call init
|
||
'**********************************
|
||
'顧客別フォルダが存在するか確認
|
||
Dim fso As Object
|
||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||
|
||
If Not fso.FolderExists(currentDirPath & "\" & workFolder) Then
|
||
'ない場合はフォルダを作成
|
||
fso.CreateFolder (currentDirPath & "\" & workFolder)
|
||
|
||
End If
|
||
Dim filePath
|
||
filePath = ThisWorkbook.Path & "\"
|
||
Dim fileName2
|
||
fileName2 = workFolder & "■" & fileName
|
||
|
||
'保存先
|
||
Dim saveFile
|
||
|
||
saveFile = filePath & workFolder & "\" & fileName2 & ".pdf"
|
||
|
||
Debug.Print saveFile
|
||
|
||
Worksheets(shName).Range("A1").Select
|
||
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=saveFile _
|
||
, Quality:=xlQualityStandard, _
|
||
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
|
||
|
||
End Function
|