- ベストアンサー
エクセルをVBAでOUTLOOKで送信したい(再)
数年前にエクセルをPDFにして添付ファイルとしてOUTLOOKで送信するコードを教えてもらって毎日のように便利に使っているのですが、今回は元のマクロ付きエクセルのまま同じことがしたく、試行錯誤でpdfをxlmsに変えてみたら、メールは起動して来るのですが 「ファイルが見つかりません」とエクセルが添付されません。 どなたかどこを修正すれば良いのかHELPお願いします。 Option Explicit Sub Saveaspdfandsend() Dim xSht As Worksheet 'Dim xFileDlg As FileDialog Dim xFolder As String 'Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Const PdfDir = "\\XXXX\TEST報告書成績表" 'PDFを保存するフォルダー Set xSht = ActiveSheet 'Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) ' 'If xFileDlg.Show = True Then ' xFolder = xFileDlg.SelectedItems(1) 'Else ' MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" ' Exit Sub 'End If xFolder = PdfDir & "\" & xSht.Cells(22, 5).Value & " " & xSht.Cells(1, 1).Value & ".pdf" 'Check if file already exist 'If Len(Dir(xFolder)) > 0 Then ' xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ ' vbYesNo + vbQuestion, "File Exists") ' On Error Resume Next ' If xYesorNo = vbYes Then ' Kill xFolder ' Else ' MsgBox "if you don't overwrite the existing PDF, I can't continue." _ ' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" ' Exit Sub ' End If ' If Err.Number <> 0 Then ' MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ ' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" ' Exit Sub ' End If 'End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "-----.co.jp" .CC = "----.co.jp" .Subject = "XXX報告書" & " " & Range("D10") .Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部" .Attachments.Add xFolder 'If DisplayEmail = False Then '.Send 'End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub
- みんなの回答 (14)
- 専門家の回答
質問者が選んだベストアンサー
その他の回答 (13)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- HohoPapa
- ベストアンサー率65% (454/692)
- HohoPapa
- ベストアンサー率65% (454/692)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- HohoPapa
- ベストアンサー率65% (454/692)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- kkkkkm
- ベストアンサー率65% (1633/2476)
- 1
- 2
関連するQ&A
- エクセルでセル内容でpdfで保存しメールの起動まで
長くなってしまって済みません。 先日(2018/12/28)ここで上記のマクロのコードを教えてもらって問題なく使い始めたのですが、別のBookにコピーして、ファイル名のセルを(10,4)と(1,1)から(15,4)と(1,1))に変更すると「実行時エラー 13、型が一致しません」と出ます。 うまくいっているシートのファイル名はD10+A1のセルで、今度はD15+A1をファイル名にしただけなのですが。。。。 (10,4)と(1,1)のままだと普通にメールが起動してくるのですがD10が空白セルの為A1の内容だけでファイル名になってしまいます。 ちなみにそのシートのD10に数値+アルファベットを入れると「型が一致しません」と上記と同じエラーが出ます。 教えてもらったコードのファイル名の(下の)セルの数値だけ変えたらうまくいったと思うのですが、今回はなぜかエラーになってしまいます。 質問ではA1+B1で質問しましたので(1,1)と(1,2)になっています。 xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf" 全部のコードは下記の通りです。 Option Explicit Sub Saveaspdfandsend() Dim xSht As Worksheet 'Dim xFileDlg As FileDialog Dim xFolder As String 'Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Const PdfDir = "C:\OKWave" 'PDFを保存するフォルダー Set xSht = ActiveSheet 'Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) ' 'If xFileDlg.Show = True Then ' xFolder = xFileDlg.SelectedItems(1) 'Else ' MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" ' Exit Sub 'End If xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf" 'Check if file already exist 'If Len(Dir(xFolder)) > 0 Then ' xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ ' vbYesNo + vbQuestion, "File Exists") ' On Error Resume Next ' If xYesorNo = vbYes Then ' Kill xFolder ' Else ' MsgBox "if you don't overwrite the existing PDF, I can't continue." _ ' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" ' Exit Sub ' End If ' If Err.Number <> 0 Then ' MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ ' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" ' Exit Sub ' End If 'End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "" .CC = "" .Subject = "" .Attachments.Add xFolder 'If DisplayEmail = False Then '.Send 'End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub
- ベストアンサー
- Excel(エクセル)
- VBAでMP3を鳴らしたい
vbaについて質問です。 MP3ファイルを鳴らしたいのですがうまくいきません。 --------------------------------------------------------- Sub Macro1() Dim SoundFile As String SoundFile = "C:\終了音.mp3" If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If Shell "mplay32.exe /play /close " & SoundFile End Sub --------------------------------------------------------- を実行すると、 「Shell "mplay32.exe /play /close " & SoundFile」 の部分で 実行時エラー53 ファイルが見つかりません。 になります。 しかし、 If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If の部分では問題ないので、ファイルはある事になってると思うのですが、 なぜ「Shell "mplay32.exe /play /close " & SoundFile」の部分でエラーになるのでしょうか? スペックは、エクセル2007、windows7です。 ご回答よろしくお願いします。
- ベストアンサー
- Visual Basic
- Outlook2007送信前の宛先確認のVBAにて
Outlook2007 送信前の宛先確認のマクロを設定したいと考えています。 Option Explicit Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) On Error GoTo Ex ception Dim strCC strCC = vbCrLf Dim objRec As Recipients For Each objRec In Item.Recipients strCC = strCC & objRec.Name & vbCrLf Next Dim strMsg As String strMsg = "件名:" & Item.Subject & vbCrLf & _ _ strCC & vbCrLf & _ _ "上記の宛先に、メールを送信してもよろしいですか?" If MsgBox(strMsg, vbExclamation + vbYesNo + vbDefaultButton2) <> vbYes Then Cancel = True End If On Error GoTo 0 Exit Sub Exception: MsgBox CStr(Err.Number) & ":" & Err.Description, vbOkOnly + vbCritical Cancel = True Exit Sub これだけだと、End subが必要ですというポップアップがあがり、付加すると『型が一致しません』というポップアップがあがってしまいます。 どうすれば良いか教えていただけますか? あと、宛先をグループ登録してる場合、グループ登録している宛先を氏名で表示する方法はありますでしょうか??
- 締切済み
- Visual Basic
- Excel VBAで検索(Win2000 Excel2000)
現在、下記のようなコードを書いています。データテーブルの縦と横の検索値を探してその列数と行数を返したいのですが、下記の Sub検索1 と Sub検索2 を1つのSubで実行させるにはどうしたらよいのでしょうか?よろしくお願い致します。 ----------------------------------------- Sub 検索1() Worksheets("Data").Activate Dim x As Integer For x = 3 To 22 If Cells(2, x).Value >= 12 Then MsgBox x Exit Sub End If Next MsgBox "見つかりません" End Sub --------------------------------------------- Sub 検索2() Worksheets("Data").Activate Dim i As Integer For i = 4 To 42 If Cells(i, 2).Value = "A" Then MsgBox i Exit Sub End If Next MsgBox "見つかりません" End Sub
- ベストアンサー
- オフィス系ソフト
- アクセスの印刷VBAを教えて下さい
アクセス初心者です。 バージョンは2002を使っています。 ネットで探して詳しく分からないままプログラムしています。 フォームで印刷のコマンドボタンを作ってそのボタンをクリックすると表示されてる 1ページのみ印刷したいのですが全てのレコードが印刷されてしまいます。 どうすればいいのか教えて下さい。 下記が今現在のVBAです。 Private Sub 印刷_Click() Dim varCopies As Variant varCopies = InputBox("部数を数字で入力してください", "印刷部数の指定") If Len(varCopies) = 0 Then Exit Sub End If If IsNumeric(varCopies) = False Then MsgBox "部数は数字で入力してください", vbOKOnly + vbCritical, "入力エラー" Exit Sub ElseIf CLng(varCopies) = 0 Then MsgBox "部数は0以上で入力してください", vbOKOnly + vbCritical, "入力エラー" Exit Sub End If If MsgBox("印刷しますか?" & vbCrLf & "部数=" & varCopies _ , vbYesNo + vbInformation, "印刷の確認") = vbYes Then DoCmd.OpenForm "伝票", acPreview, , , acFormReadOnly DoCmd.PrintOut acPrintAll, , , , CLng(varCopies) DoCmd.Close acForm, "伝票" End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAにて保存するとき
Private Sub Workbook_BeforeClose(Cancel As Boolean) If MsgBox("エクセルを終了してもよろしいですか?", vbYesNo) = vbNo Then Cancel = True Exit Sub End If Application.DisplayAlerts = False Application.Quit End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox "そのボタンでは保存できません。" & vbCrLf & _ "雛形は残しておきましょう" & vbCrLf & _ "" & vbCrLf & _ "ツールバーの「マクロなし出力」から保存できます。" Cancel = True End Sub という二つのマクロをThisworkbookにいれてあるんですが、 この二つを有効(今は2つ目を'でコメント状態にしてあるので保存可)にすると保存できなくて困っています。 二つを有効にした時はどのようにほぞんすればいいですか?
- 締切済み
- Visual Basic
- 音楽ファイルが再生できない(VBA)
http://qa.nou-college.net/qa4877134.html の続きですが Sub Sample1() Dim SoundFile As String SoundFile = "C:\Users\Music\サザンオールスターズ/希望の轍.mp3" If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If Shell "mplay32.exe /play /close " & SoundFile End Sub を実行すると「ファイルが見つかりません」となります。 他のMP3ファイルでも同じです。 APIを使う方法なら成功しました。 「MsgBox SoundFile & vbCrLf & "がありません。", 」 とならないのでファイルは見つかっているのだと思います。 何か原因がわかる方よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセル VBA OptionButtonからTextBox
すいません! OptionButtonなら 下記の記述でエラー表示を 簡単にできるのですが これがOptionButtonではなく TextBoxならどのように変化したら 良いのでしょうか? すいません、教えて下さい! Private Sub 記録_Click() Dim i As Integer Dim Cnt As Integer Cnt = 0 For i = 1 To 6 Step 1 If Me.Controls("OptionButton" & i).Value Then Cnt = i Exit For End If Next i If Cnt = 0 Then MsgBox "選択されていません" Exit Sub End If If Me.Controls("Combobox" & Cnt).Value = "" Then MsgBox Me.Controls("OptionButton" & Cnt).Caption & " の内容が選択されていません" Exit Sub End If With 記入フォーム .TextBox5.Value = Me.Controls("OptionButton" & Cnt).Caption .TextBox6.Value = Me.Controls("Combobox" & Cnt).Value End With Unload Me End Sub
- ベストアンサー
- オフィス系ソフト
- 奇数・偶数の判断 VBA
Sub Macro1() Dim i As Long i = 1 For i = 1 To 10 If i = ? Then '偶数ならと言うコード MsgBox "偶数です" Else MsgBox "奇数です" End If Next End Sub ここまでは自分で作れたのですが、iが奇数か偶数かを判断するコードがわかりません。 ご教授よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- VBAで2つのBOOKのセル範囲を比較
異なるBOOKのセル範囲のデータを照らし合わせ、不一致があるか確認したいのです。 その際、セル範囲をあらかじめVBAで決め打ちするのではなく、画面上で選択したいので、Application.Inputboxを使おうと思います。 以下のコードで一応はできたのですが、これを使うためには、画面を分割して2つのBOOKの該当箇所を「並べて比較」で並べて表示させておかなければ片方のシートしか選択することができません。 選択範囲が小さい場合は並べて表示させても問題ないのですが、かなり大きな範囲を選択する場合は、並べて表示で画面が半分にされると選択するのが大変です。 まず比較元シートを画面全体に表示して範囲選択し、次に比較先を表示して選択できるようにする方法があばとても作業が楽になります。 ご教示いただければ幸いです。 Sub 選択範囲データ比較() '2019/05/16 Dim myV, myW Dim buf(1) As Range Dim i As Long, m As Long, j As Long Set buf(0) = Application.InputBox(Prompt:="セルを選択してください。", Type:=8) myV = buf(0).Value Set buf(1) = Application.InputBox(Prompt:="比較するセルを選択してください。", Type:=8) myW = buf(1).Value If UBound(myV, 1) <> UBound(myW, 1) Then MsgBox "配列 1次元要素数が異なります。", vbCritical Exit Sub End If If UBound(myV, 2) <> UBound(myW, 2) Then MsgBox "配列 2次元要素数が異なります。", vbCritical Exit Sub End If For i = LBound(myV, 1) To UBound(myW, 1) For n = LBound(myV, 2) To UBound(myW, 2) If myV(i, n) <> myW(i, n) Then j = j + 1 End If Next n Next i If j > 0 Then MsgBox j & "個、相違があります。", vbCritical Else MsgBox "同一です。" _ & vbCrLf & "" _ & vbCrLf & "1次元:" & UBound(myV, 1) & "個" _ & vbCrLf & "2次元:" & UBound(myV, 2) & "個" End If End Sub
- ベストアンサー
- Excel(エクセル)
お礼
今回はご丁寧な指導で ・・予めFileSystemObjectを参照設定 が出来るようになりましたが、残念ですが別の方法での対処を検討します。 久々にHohoPapaさんとコミできたので安心?しました。 上記方法でトラブったらまた宜しくお願いします HohoPapaさんの意図した動作は1発で動いたことには改めて感動しました。 今回は当方の背景の説明不足のためにお手数をお掛けしてしまいました。ごめんなさい!
補足
お正月に孫のところへ出かけていたので対応が遅れ申し訳ありません。 出社早々にためしてみました。 マクロ付きの自身のファイルの保存とメール送信までは問題ないのですが、メールに添付されたエクセルのマクロを動かすとやはり同じところで止まります。 休み中に色々考えたのですが、過去にHohoPapaさんに教えて頂いたシート(自身)のコピーを保存するコードと指定セルの内容を一覧表の下に参照するコードがあるので、別々に動かすことにトライしてみます。 今回質問したコードは顧客様にメールで送るためのコード(HohoPapa作)でこれの修正が簡単かと思いましたが、他のVBAとの相性があるので当方にはハードル高しと判断し、一旦締め切らせて頂きます。