VBA Access Format Chart in Excel - excel

EDITED
If you guys have a link that might help with this problem I'd really like to read it, because so far I haven't seen anything very useful.
In access I'm trying to export arbitrary data to excel, create multiple charts (right now just working on a pie chart), format these charts and then send them to a blank (Chart) sheet. So far I've exported the data and am able to create the charts, I just have no idea how to format them.
The formatting I want to do is to get rid of the legend, put data labels with the name, value, and percentage, and move it to a "Chart" sheet.
Edit I am now able to get rid of the legend as well as insert the data labels with name, value and percentage. I am still stuck on moving the Chart object to a new sheet, code at bottom.
I've also tried to record a macro in excel, edit it slightly and then move it over to access but I keep erroring out, usually with an error similar to "This object doesn't have that method". Below I'll include a test table that I might get and how I create the pie chart.
Code:
Function Excel_Export_Two_Column()
Dim db As DAO.Database, rs As DAO.Recordset
Dim WBO As Object, WSO As Object, WSO2 As Object, XLO As Object, oChart As Object
Dim x As Long, y As Long, z As Integer, strTab As String, strcompany As String
Dim endTable As Long
Dim tempName As String, tempNum1 As Long, tempNum2 As Long, totalEnd As Long
z = 1
Set db = CurrentDb()
Set rs = db.OpenRecordset("QRY2Col")
Set XLO = CreateObject("Excel.Application")
XLO.Application.Workbooks.Add
Set WBO = XLO.Application.ActiveWorkbook
Set WSO = WBO.Worksheets(1)
Set WSO2 = WBO.Worksheets(2)
WSO.Name = Left("export", 31)
For y = 0 To rs.Fields.Count - 1
WSO.Cells(1, 1) = "Num"
WSO.Cells(1, y + 2) = rs(y).Name
Next y
x = 1
Do While Not rs.EOF()
x = x + 1
WSO.Cells(x, 1) = x - 1
For y = 0 To rs.Fields.Count - 1
WSO.Cells(x, y + 2) = Trim(rs(y))
Next y
rs.MoveNext
DoEvents
Loop
WSO.Cells.Rows(1).AutoFilter
WSO.Application.Cells.Select
WSO.Cells.EntireColumn.AutoFit
x = 1
Do While WSO.Cells(x, 1) <> ""
x = x + 1
Loop
endTable = x - 1
WSO2.Cells(1, 1) = "Name"
WSO2.Cells(1, 2) = "Num"
totalEnd = 2
For x = 2 To endTable
If (WSO.Cells(x, 2) <> "") Then
tempName = WSO.Cells(x, 2)
tempNum1 = WSO.Cells(x, 3)
For y = 2 To totalEnd
If (WSO2.Cells(y, 1) = tempName) Then
tempNum2 = WSO2.Cells(y, 2)
WSO2.Cells(y, 2) = tempNum1 + tempNum2
Exit For
ElseIf (y = totalEnd) Then
WSO2.Cells(y, 1) = tempName
WSO2.Cells(y, 2) = tempNum1
totalEnd = totalEnd + 1
End If
Next y
End If
Next x
Set oChart = WSO2.ChartObjects.Add(500, 100, 500, 300).Chart
oChart.SetSourceData Source:=WSO2.Range("A1").Resize(totalEnd - 1, 2)
oChart.ChartType = 5
strcompany = "Export"
If Dir(CurrentProject.Path & "\COLA_AR_" & Format(Date, "yyyymm") & "_XXX_" & strcompany & ".xlsx") <> "" Then
Kill CurrentProject.Path & "\COLA_AR_" & Format(Date, "yyyymm") & "_XXX_" & strcompany & ".xlsx"
End If
Call WBO.SaveAs(CurrentProject.Path & "\COLA_AR_" & Format(Date, "yyyymm") & "_test_2_Col.xlsx")
WBO.Close savechanges:=True
Set WBO = Nothing
XLO.Application.Quit
Set XLO = Nothing
rs.Close
db.Close
End Function
Table: Note that this table is in a Query (named "QRY2Col") in Access
Field1 Field2
CTOD 64646515
BFTBC2 6656532
WTOW 451512355
DT3 684321818
STC2 652553548
BFTBC2 12
DT3 84954987
ATCR 99999999
CTOD 64185435
BFTBC2 321569846
STC2 6543518
STC2 3518684
ATCR 35481354
Code for data labels
Set oChart = WSO2.ChartObjects.Add(500, 100, 500, 300).Chart
oChart.SetSourceData Source:=WSO2.Range("A1").Resize(totalEnd - 1, 2)
' Number corresponds to a pie chart
oChart.ChartType = 5
' Adds data Labels
oChart.SeriesCollection(1).HasDataLabels = True
' Format chart
oChart.SeriesCollection(1).DataLabels.ShowCategoryName = True
oChart.SeriesCollection(1).DataLabels.ShowPercentage = True
oChart.SeriesCollection(1).HasLeaderLines = True
oChart.Legend.Delete
Attempted code to move chart
Below is an example of what I recorded (edited by adding "oChart") but this still doesn't work. The problem that gets highlighted is the "xlLocationAsNewSheet" and VBA says that the "Variable is not defined".
oChart.Location Where:=xlLocationAsNewSheet
Thank you,
Jesse Smothermon

For the last part, try this:
oChart.Location Where:=1
' xlLocationAsNewSheet = 1
' xlLocationAsObject = 2
' xlLocationAutomatic = 3
As David pointed out, you cannot use the types/enums etcetera defined in the Excel object library without a reference to it, thus you are stuck using integer constants instead.

Related

After using hyperlink to open several pdf files, the Acrobat window is in full mode. How to snap_to_left that window from the same VBA Excel macro?

I have to review scanned documents in order to check the certainty of data in other documents called resolutions.
Each pdf file name contains the number and the date of passing of each resolution.
I made a VBA excel macro that reads all the pdf files in a folder, extracts the date of passing, and builds a list ordered chronologically according to that dates. Latest to newest. Later the macro opens the pdf files in that order by using ActiveWorkbook.FollowHyperlink.
I snap the big screen of my PC into two parts, the leftmost for Adobe Acrobat, and the rightmost for the database containing the data records.
Problem is that after opening the pdf files, Adobe Acrobat is opened in full mode.
I have this code that functions perfectly but DOES NOT RETURN the Adobe Acrobat to the leftmost part of the screen.
Sub OpenPDF()
Dim i As Long, j As Long, k As Long, m As Long, uFila As Long, n As Long
Dim oFSO As Object, oFile As Object
Dim oCarpeta As Object
Dim oArchivo As Object
Dim x As String, z As String, y() As Variant, Hoja As Worksheet
Dim Partes() As String, returnValue As Boolean, bMinimize As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oCarpeta = oFSO.GetFolder("X:\_RIE\Resoluciones")
n = 0: bMinimize = 1
For Each oArchivo In oCarpeta.Files
n = n + 1
ReDim Preserve y(n)
x = oArchivo.Name
Partes = Split(x, "-")
x = Trim(Partes(3))
x = Right(x, 4) & Mid(x, 3, 2) & Left(x, 2) ' x take the yyyymmdd format
' An "*" is inserted for future use in spliting the long name
y(n) = x & "*" & oArchivo.Name
Next oArchivo
'The Ordenado function takes the array sent and order it
y = Ordenado(y)
'Now the Acrobat app is called to close all possible pdf files opened.
Set oFSO = CreateObject("AcroExch.App")
oFSO.CloseAllDocs
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oCarpeta = oFSO.GetFolder("x:\_RIE\Resoluciones")
MsgBox "The documents will be open in chronological order." & Chr(13) & _
"Oldest to the left and so on." & Chr(13) & _
"At final you will have to restore the Adobe Acrobat window," & Chr(13) & _
"by clicking the Windows Key + Left Arrow Key."
For i = 1 To n
Partes = Split(y(i), "*")
y(i) = oCarpeta.Path & "\" & Partes(1)
Next
'This loop opens directly each pdf file.
For i = 1 To n
x = y(i)
ActiveWorkbook.FollowHyperlink (x)
Next i
'The Adobe Acrobat is invoked
Set oFSO = Nothing
Set oFSO = CreateObject("AcroExch.App")
With oFSO
.Show
'All smooth until here
'Next line is not functioning
.Restore True
End With
'That's the reason why the user has to pulse the Restore icon
'in the rightmost upper corner of the screen or
'press the Windows Key + Left Arrow Key.
Set Hoja = ActiveWorkbook.Worksheets(1)
Hoja.Activate
End Sub
Function Ordenado(myArray As Variant)
Dim i As Long
Dim j As Long
Dim Temp
'Sort the Array A-Z
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray)
If UCase(myArray(i)) > UCase(myArray(j)) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
Ordenado = myArray
End Function

When importing an Excel Sheet to Access using VBA how do you overcome slashes in the cell causing runtime 3075

Found a similar post on this question, but it was using an SQL Query and I'm using a DLookup.
I'm importing an Excel sheet to Access.
I'm getting the run-time 3075 - Syntax error (missing operator)... '[Component]='don't have/want a car'.
That particular Component already exists in the DB and it errors out at the comparison.
It's either the ' or the / that are causing the hang-up
Oh and I went with Variant on the tmpComponent b/c if I go String I get an Object required error at the Set tmpComponent = ... line. Maybe that is the problem, just not really sure.
Here is my Code and the bold is where the error occurs.
Thank you in advance for any direction you can provide.
Set rsCat = db.OpenRecordset("Categories", dbOpenDynaset, dbSeeChanges)
Dim x As Integer: x = 2
Dim LRow As Integer: LRow = ExLWb.Sheets("Categories").Cells(Rows.Count, 2).End(xlUp).Row
Dim tmpPFId As Variant, tmpCategory As Variant, tmpComponent As Variant, tmpSyntax As Variant, tmpCycle As Variant
Dim NewItem As Integer
NewItem = 0
'******************* LOOP THROUGH SPREADSHEET UPDATING CATEGORY TABLE
For x = 2 To LRow
Set tmpPFId = ExLWs.Cells(x, 2)
Set tmpCategory = ExLWs.Cells(x, 3)
Set tmpComponent = ExLWs.Cells(x, 4)
Set tmpSyntax = ExLWs.Cells(x, 5)
Set tmpCycle = ExLWs.Cells(x, 9)
**If IsNull(DLookup("[Component]", "[Categories]", "[Component]= '" & tmpComponent & "'")) Then**
rsCat.AddNew
rsCat!PF_ID = tmpPFId
rsCat!Category = tmpCategory
rsCat!component = tmpComponent
rsCat!Syntax = tmpSyntax
rsCat!Active = True
rsCat!Available = True
rsCat!Cycle = tmpCycle
rsCat.Update
NewItem = NewItem + 1
End If
Next x
Disregard, I figured out I should have gone with:
If IsNull(DLookup("[Category]", "[Categories]", "[Category]= """ & tmpCategory & """ & [Component]= """ & tmpComponent & """")) Then

How to delete one shape off of powerpoint using VBA

I have a macro that deletes all of the tables in my powerpoint and then a different macro to import the new tables from excel. I'm having trouble figuring out how to only delete that shape, however. The code I have right now deletes the title of the slide and all of the comments too (see below for current). Any ideas how to only remove that one shape? OR is it possible to delete only pictures and not text??
Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
Dim i As Long, j As Long
Set ppt = GetObject(, "PowerPoint.Application")
Set pr = ppt.Presentations(1)
For j = 10 To 1 Step -1
Set sl = pr.Slides(j)
For i = sl.Shapes.Count To 1 Step -1
sl.Shapes(i).Delete
Next i
Next j
'Record the date & time of procedure execution
Range("DeletePreviousPPTData").Value = Format(Now(), "mm/dd/yy") & " - " & Format(TimeValue(Now), "hh:mm AM/PM")
End Sub
Your code is deleting all of the shapes on the slide.
Before deleting each shape, make sure that it's a table.
As #BigBen mentioned, .HasTable will identify shapes that are tables, but it'll miss tables contained in content placeholders.
This IsTable function will test for both. Use it like so:
Sub YourSubName()
Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
Dim i As Long, j As Long
Set ppt = GetObject(, "PowerPoint.Application")
Set pr = ppt.Presentations(1)
For j = 10 To 1 Step -1
Set sl = pr.Slides(j)
For i = sl.Shapes.Count To 1 Step -1
' ADD THIS TEST
If IsTable(sl.Shapes(i)) then
sl.Shapes(i).Delete
End if
Next i
Next j
'Record the date & time of procedure execution
Range("DeletePreviousPPTData").Value = Format(Now(), "mm/dd/yy") & " - " & Format(TimeValue(Now), "hh:mm AM/PM")
End Sub
Function IsTable(oSh As Shape) As Boolean
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoTable Then
IsTable = True
End If
Else
If oSh.HasTable Then
IsTable = True
End If
End If
End Function

How to show thumbnail of a dwg-File in a excel VBA Userform

I want to write a little DMS to tag and save ACAD files. For this i am using Excel VBA. Using with ACAD 2014 / 2015 / 2019.
Step 1 - save drawing:
When copy some parts of the drawing, there is a copy in %temp% and something like a WindowsMetaFile (WMF) in clipboard.
Here i grab the copy from %temp%.
Step 2 - load file to ACAD:
With serching or filtering i can load theese files as block into ACAD.
By filtering, a listbox show the different tags.
Also i wan´t to show a Thumnail of the ACAD file in a Imagebox. But it doesn´t work.
Problem:
How to show thumnail from dwg´s in userform?
I think there is more than one solution. However I do not know how.
Solution 1:
In Step1: Copy WMF from Clipboard and save to file. Maybe as jpg or png?!?
In Step2: Load Image or WMF from File and show in Imagebox.
Solution 2:
In Step 1: Create a Thumbnail of the dwg.
In Step 2: Load Thumbnail to Imagebox.
Solution 3:
DWG TrueView Control
https://through-the-interface.typepad.com/through_the_interface/2007/10/au-handouts-t-1.html
Need a registration. But only have Acad student version.
Solution 4:
AutoCAD DwgThumbnail Control
https://forums.augi.com/showthread.php?42906-DWG-Block-Preview-Image
But there isn´t a "DwgThumbnail.ocx" file
'Step 1 - it works
Private Sub cmdSpeichern_Click()
'Spaltentitel
Dim SpalteID, SpalteBeschreibung, SpalteDatum, SpalteHäufigkeit, SpalteSystemhersteller, SpalteSystem, SpalteElement, SpalteEinbaulage As String
SpalteID = 1
SpalteDatum = 2
SpalteBeschreibung = 3
SpalteHäufigkeit = 4
SpalteSystemhersteller = 5
SpalteSystem = 6
SpalteElement = 7
SpalteEinbaulage = 8
Dim Pfad, teil
Dim Dateiname As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
Dim FileSpec As String
Dim NewestFile As String
Dim lngZeile As Long
Dim WindowsBenutzername As String
WindowsBenutzername = VBA.Environ("UserName")
Pfad = "C:\Users\" & WindowsBenutzername & "\AppData\Local\Temp\"
teil = "A$"
Dateiname = Dir(Pfad & teil & "?????????.DWG")
If Dateiname <> "" Then
MostRecentFile = Dateiname
MostRecentDate = FileDateTime(Pfad & Dateiname)
Do While Dateiname <> ""
If FileDateTime(Pfad & Dateiname) > MostRecentDate Then
MostRecentFile = Dateiname
MostRecentDate = FileDateTime(Pfad & Dateiname)
End If
Dateiname = Dir
Loop
End If
NewestFile = MostRecentFile
'MsgBox NewestFile
'Datei kopieren
Dim myFSO As Object
Dim qFolder As String, tFolder As String
Dim qFile As String
qFile = NewestFile
qFolder = Pfad
tFolder = ThisWorkbook.Path & "\dwg\"
Set myFSO = CreateObject("Scripting.FileSystemObject")
myFSO.copyfile qFolder & qFile, tFolder & qFile, True
'Datei umbenennen
Name tFolder & NewestFile As tFolder & Tabelle2.Cells(1, 2) & ".dwg"
'Infos in Excel einragen
lngZeile = 3
Do Until Tabelle1.Cells(lngZeile, 1) = ""
lngZeile = lngZeile + 1
Loop
If Tabelle1.Cells(lngZeile + 1, 1) = "" Then
Tabelle1.Cells(lngZeile, SpalteID) = Tabelle2.Cells(1, 2)
Tabelle1.Cells(lngZeile, SpalteDatum) = Now ' Format
Tabelle1.Cells(lngZeile, SpalteBeschreibung) = txtBeschreibung.Value
Tabelle1.Cells(lngZeile, SpalteHäufigkeit) = "0"
Tabelle1.Cells(lngZeile, SpalteSystemhersteller) = cboSystemhersteller
Tabelle1.Cells(lngZeile, SpalteSystem) = cboSystem.Value
Tabelle1.Cells(lngZeile, SpalteElement) = cboElement.Value
'Tabelle1.Cells(lngZeile, SpalteEinbaulage) = cboEinbaulage.Value
End If
'ID erhöhen
Tabelle2.Cells(1, 2) = Tabelle2.Cells(1, 2) + 1
'Datei abspeichern
ThisWorkbook.Save
'Fertigmeldung
MsgBox "Zeichnung erfolgreich gespeichert."
End Sub
'Step 2 - It´s not final, but works
Private Sub CommandButton3_Click()
Dim insertionPnt(0 To 2) As Double
inserationPnt = AutoCAD.Application.ActiveDocument.Utility.GetPoint(, "Einfügepunkt wählen: ")
Dim BlockRef As AcadBlockReference
'Runden
inserationPnt(0) = Round(inserationPnt(0), 0)
inserationPnt(1) = Round(inserationPnt(1), 0)
inserationPnt(2) = 0
insertionPnt(0) = inserationPnt(0): insertionPnt(1) = inserationPnt(1): insertionPnt(2) = inserationPnt(2)
FileToInsert = ThisWorkbook.Path & "\dwg\10.dwg"
Set BlockRef = AutoCAD.Application.ActiveDocument.ModelSpace.InsertBlock(insertionPnt, FileToInsert, 1#, 1#, 1#, 0)
End Sub
How to say it nicely :) Doesnt work that easy. "In Trough the Interface" is a article how to generate a block thumbnail. Thumbnails genration
You may also try to store WMF files from a block and convert them - VBA sample downstairs. But thats also not really nice. There is stupidly no ready to use API to fetch all Block images by VBA nor by .NET. There might be some expensive DWG reading libs out. But i would wrap a modified Version of Kens block into a vba callable DLL and act with her (there are c# to vba converters out ). At all nothing that easy but will work. And just to mention. That will not be that fast in any case. If the block images are not already generated this will take time.And how to store them in the excel file ? Might be a idea to put them in a database as a blob and use some database connectors. All at all a nightmare.
Sub BlockPreview(blockname As Variant, imageControlName As Variant, UserForm As UserForm)
'
' Biolight - 2008
' http://biocad.blogspot.com/
' Biolightant(at)gmail.com
'
Dim blockRefObj As AcadBlockReference
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = -10000000000000#: insertionPnt(1) = -10000000000000#: insertionPnt(2) = 0
' Insert Block
Set blockRefObj = ThisDrawing.modelspace.InsertBlock(insertionPnt, blockname, 1#, 1#, 1#, 0)
Dim minPt As Variant
Dim maxPt As Variant
blockRefObj.GetBoundingBox minPt, maxPt
minPt(0) = minPt(0) - 2
minPt(1) = minPt(1) - 2
maxPt(0) = maxPt(0) + 2
maxPt(1) = maxPt(1) + 2
' Block Zoom
ZoomWindow minPt, maxPt
ThisDrawing.REGEN acActiveViewport
'ThisDrawing.Regen True
' Make SelectionSets
Dim FType(0 To 1) As Integer, FData(0 To 1)
Dim BlockSS As AcadSelectionSet
On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If ERR Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.CLEAR
FType(0) = 0: FData(0) = "INSERT": FType(1) = 2: FData(1) = blockname
BlockSS.Select acSelectionSetAll, , , FType, FData
' Block Export image(wmf)
ThisDrawing.Export ThisDrawing.PATH & "\" & blockname, "wmf", BlockSS
BlockSS.ITEM(0).DELETE
BlockSS.DELETE
ThisDrawing.applicaTION.UPDATE
' ZoomPrevious
applicaTION.ZoomPrevious
' UserForm image control picture = block.wmf
UserForm.CONTROLS(imageControlName).Picture = LoadPicture(ThisDrawing.PATH & "\" & blockname & ".wmf")
UserForm.CONTROLS(imageControlName).PictureAlignment = fmPictureAlignmentCenter
UserForm.CONTROLS(imageControlName).PictureSizeMode = fmPictureSizeModeZoom
' Delete block.wmf file
Dim fs, F, F1, FC, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.getfolder(ThisDrawing.PATH)
Set FC = F.FILES
For Each F1 In FC
If F1.NAME = blockname & ".wmf" Then
F1.DELETE
End If
Next
On Error GoTo 0
End Sub

Copying data from excel to pdf form, works for the first but

I want to export data from Excel to a pdf-Form using vba.
I used this approach:
https://forums.adobe.com/thread/302309
When I copy just one field it works, but I want to copy all the fields from A1:K2 where the field titles are always in the top and the content in the rows below.
I think my problem is that I don't switch back to Excel when I am trying to copy the next value and field title. But I don't know how to do it properly.
So I would be really glad if someone could tell me.
The files could be downloaded here:
http://www.xn--frank-mller-zhb.net/Formulardings.zip
Sub Pdfdings()
Dim gApp As Acrobat.CAcroApp
Dim avdoc As Acrobat.CAcroAVDoc
Dim gPDDoc As Acrobat.CAcroPDDoc
Const DOC_FOLDER As String = "C:\Users\Frank\Documents"
Dim x As Boolean
Set gApp = CreateObject("AcroExch.App")
Set gPDDoc = CreateObject("AcroExch.PDDoc")
Set avdoc = CreateObject("AcroExch.AVDoc")
'Hides Acrobat - So Far So Good
'gApp.Hide
Dim FormApp As AFORMAUTLib.AFormApp
Dim AcroForm As AFORMAUTLib.Fields
Dim Field As AFORMAUTLib.Field
Dim z, i, j, n As Integer
Dim wksTab1 As Worksheet
Dim Feld, Inhalt As String
Set wksTab1 = Sheets("Tabelle2")
'Open PDF that I choose. Acrobat still has not flashed on my screen
j = 1
i = 2
While i < 3
x = avdoc.Open(DOC_FOLDER & "\formular_ve01a.pdf", "temp")
'Acrobat Now Pops up on my screen. However, I get an error without this line. avdoc.Show works the same as Maximize it seems.
avdoc.Maximize (1)
'Hides it again, right after it opens. This creates a flash
'gApp.Hide
Set FormApp = CreateObject("AFormAut.App")
While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
For Each Field In FormApp.Fields
If Field.Name = Feld Then
Field.Value = Inhalt
End If
Next
j = j + 1
Wend
Dim sDoc
Set sDoc = avdoc.GetPDDoc
saveOk = sDoc.Save(1, DOC_FOLDER & "\OK_Formular" & wksTab1.Cells(1, 1).Value & ".pdf")
avdoc.Close (1)
gApp.Exit
i = i + 1
Wend
End Sub
Set A1:K2 as your print range
Set your printer to a PDF Writer (CutePDF or PDF995 or other)
Print
solution I got by the help of another forum
<pre>While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
FormApp.Fields(Feld).Value = Inhalt
j = j + 1
Wend
Thank you everyone!

Resources