Skip to content

Commit 0a9ca8d

Browse files
ericremoreynoldsericremoreynolds
committed
Minor change
Added `xlpython_xlam_vba_code.bas` to facilitate diff
1 parent 8f12ce9 commit 0a9ca8d

File tree

2 files changed

+270
-0
lines changed

2 files changed

+270
-0
lines changed

‎addin/readme.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
### Note
2+
3+
The `xlpython_xlam_vba_code.bas` file is included in this directory in order to be able to easily diff commits on git (the `.xlam` file itself is not straight-forward to diff).
4+
In order for this to work, it must of course be manually exported from the `.xlam` file before each commit.

‎addin/xlpython_xlam_vba_code.bas‎

Lines changed: 266 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,266 @@
1+
Attribute VB_Name = "ExcelPython"
2+
#If VBA7 Then
3+
4+
Private Declare PtrSafe Function GetTempPath32 Lib "kernel32" _
5+
Alias "GetTempPathA" (ByVal nBufferLength As LongPtr, _
6+
ByVal lpBuffer As String) As Long
7+
8+
Private Declare PtrSafe Function GetTempFileName32 Lib "kernel32" _
9+
Alias "GetTempFileNameA" (ByVal lpszPath As String, _
10+
ByVal lpPrefixString As String, ByVal wUnique As Long, _
11+
ByVal lpTempFileName As String) As Long
12+
13+
#Else
14+
15+
Private Declare Function GetTempPath32 Lib "kernel32" _
16+
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
17+
ByVal lpBuffer As String) As Long
18+
19+
Private Declare Function GetTempFileName32 Lib "kernel32" _
20+
Alias "GetTempFileNameA" (ByVal lpszPath As String, _
21+
ByVal lpPrefixString As String, ByVal wUnique As Long, _
22+
ByVal lpTempFileName As String) As Long
23+
24+
#End If
25+
26+
Private Function GetTempFileName()
27+
Dim sTmpPath As String * 512
28+
Dim sTmpName As String * 576
29+
Dim nRet As Long
30+
nRet = GetTempPath32(512, sTmpPath)
31+
If nRet = 0 Then Err.Raise 1234, Description:="GetTempPath failed."
32+
nRet = GetTempFileName32(sTmpPath, "vba", 0, sTmpName)
33+
If nRet = 0 Then Err.Raise 1234, Description:="GetTempFileName failed."
34+
GetTempFileName = Left$(sTmpName, InStr(sTmpName, vbNullChar) - 1)
35+
End Function
36+
37+
Function ModuleIsPresent(ByVal wb As Workbook, moduleName As String) As Boolean
38+
On Error GoTo not_present
39+
Set x = wb.VBProject.VBComponents.Item(moduleName)
40+
ModuleIsPresent = True
41+
Exit Function
42+
not_present:
43+
ModuleIsPresent = False
44+
End Function
45+
46+
47+
Sub SetupExcelPython(control As IRibbonControl)
48+
Set wb = ActiveWorkbook
49+
If wb.Path = "" Then
50+
MsgBox "Please save this workbook first, as a macro-enabled workbook."
51+
Exit Sub
52+
End If
53+
If LCase$(Right$(wb.name, 5)) <> ".xlsm" And LCase$(Right$(wb.name, 5)) <> ".xlsb" Then
54+
MsgBox "Please save this workbook, " + wb.name + ", as a macro-enabled workbook first."
55+
Exit Sub
56+
End If
57+
mssg = "This action will:" _
58+
+ vbCrLf + " - install the ExcelPython runtime in the folder '" + wb.Path + Application.PathSeparator + "xlpython'" _
59+
+ vbCrLf + " - set up this workbook ('" + wb.name + "') to interact with Python" _
60+
+ vbCrLf + vbCrLf + "Do you want to proceed?"
61+
If vbYes = MsgBox(mssg, vbYesNo, "Set up workbook for ExcelPython") Then
62+
Set fso = CreateObject("Scripting.FileSystemObject")
63+
If fso.FolderExists(wb.Path + Application.PathSeparator + "xlpython") Then
64+
isVersionOK = False
65+
ver = "?.?.?"
66+
For Each f In fso.GetFolder(ThisWorkbook.Path + Application.PathSeparator + "xlpython").Files
67+
If LCase$(Right$(f, 4)) = ".dll" Then
68+
isVersionOK = fso.FileExists(wb.Path + Application.PathSeparator + "xlpython" + Application.PathSeparator + fso.GetFileName(f))
69+
ver = Mid$(fso.GetBaseName(f), InStr(fso.GetBaseName(f), "-") + 1)
70+
Exit For
71+
End If
72+
Next f
73+
If Not isVersionOK Then
74+
MsgBox "The installation folder already exists, but it does not contain ExcelPython version " + ver + "." _
75+
+ vbCrLf + vbCrLf + "Installation folder: " + wb.Path + Application.PathSeparator + "xlpython" _
76+
+ vbCrLf + vbCrLf + "To set up a fresh install please delete it and try again. Note that you may need to close Excel to delete it." _
77+
, vbCritical, "Error installing ExcelPython runtime"
78+
Exit Sub
79+
End If
80+
Else
81+
fso.CopyFolder ThisWorkbook.Path + Application.PathSeparator + "xlpython", wb.Path + Application.PathSeparator + "xlpython"
82+
End If
83+
84+
On Error GoTo not_present
85+
wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents("xlpython")
86+
not_present:
87+
On Error GoTo 0
88+
wb.VBProject.VBComponents.Import wb.Path + Application.PathSeparator + "xlpython" + Application.PathSeparator + "xlpython.bas"
89+
90+
' create skeleton py file
91+
Set fso = CreateObject("Scripting.FileSystemObject")
92+
If Not fso.FileExists(wb.Path + Application.PathSeparator + fso.GetBaseName(wb.name) + ".py") Then
93+
Set f = fso.CreateTextFile(wb.Path + Application.PathSeparator + fso.GetBaseName(wb.name) + ".py", True)
94+
f.WriteLine "from xlpython import *"
95+
f.Close
96+
End If
97+
'MsgBox "You can now write user-defined functions for this workbook in Python in the file '" + wb.Path + Application.PathSeparator + fso.GetBaseName(wb.Name) + ".py'." + vbCrLf + "Please consult the online docs for more information on how it works.", Title:="ExcelPython setup successful!"
98+
End If
99+
End Sub
100+
101+
Sub XLPMacroOptions2010(macroName As String, desc, argdescs() As String)
102+
Application.MacroOptions macroName, Description:=desc, ArgumentDescriptions:=argdescs
103+
End Sub
104+
105+
Sub ImportPythonUDFs(control As IRibbonControl)
106+
sTab = " "
107+
108+
Set wb = ActiveWorkbook
109+
If Not ModuleIsPresent(wb, "xlpython") Then
110+
MsgBox "The active workbook does not seem to have been set up to use ExcelPython yet."
111+
Exit Sub
112+
End If
113+
114+
Set Py = Application.Run("'" + wb.name + "'!Py")
115+
116+
Set fso = CreateObject("Scripting.FileSystemObject")
117+
filename = GetTempFileName()
118+
Set f = fso.CreateTextFile(filename, True)
119+
f.WriteLine "Attribute VB_Name = ""xlpython_udfs"""
120+
f.WriteLine
121+
f.WriteLine "Function PyScriptPath() As String"
122+
f.WriteLine sTab + "PyScriptPath = Left$(ThisWorkbook.Name, Len(ThisWorkbook.Name)-5) ' assume that it ends in .xlsm"
123+
' f.WriteLine sTab + "If LCase$(Right$(PyScriptPath, 5)) = "".xlsm"" Then PyScriptPath = Left$(PyScriptPath, Len(PyScriptPath)-5)"
124+
f.WriteLine sTab + "PyScriptPath = ThisWorkbook.Path + Application.PathSeparator + PyScriptPath + "".py"""
125+
f.WriteLine "End Function"
126+
f.WriteLine
127+
128+
Dim scriptPath As String
129+
scriptPath = wb.Path + Application.PathSeparator + fso.GetBaseName(wb.name) + ".py"
130+
Set scriptVars = Py.Call(Py.Module("xlpython"), "udf_script", Py.Tuple(scriptPath))
131+
For Each svar In Py.Call(scriptVars, "values")
132+
If Py.HasAttr(svar, "__xlfunc__") Then
133+
Set xlfunc = Py.GetAttr(svar, "__xlfunc__")
134+
Set xlret = Py.GetItem(xlfunc, "ret")
135+
fname = Py.Str(Py.GetItem(xlfunc, "name"))
136+
137+
Dim ftype As String
138+
If Py.Var(Py.GetItem(xlfunc, "sub")) Then ftype = "Sub" Else ftype = "Function"
139+
140+
f.Write ftype + " " + fname + "("
141+
first = True
142+
For Each arg In Py.GetItem(xlfunc, "args")
143+
If Not Py.Bool(Py.GetItem(arg, "vba")) Then
144+
If Not first Then f.Write ", "
145+
f.Write Py.Str(Py.GetItem(arg, "name"))
146+
first = False
147+
End If
148+
Next arg
149+
f.WriteLine ")"
150+
If ftype = "Function" Then
151+
f.WriteLine sTab + "If TypeOf Application.Caller Is Range Then On Error GoTo failed"
152+
End If
153+
154+
For Each arg In Py.GetItem(xlfunc, "args")
155+
If Not Py.Bool(Py.GetItem(arg, "vba")) Then
156+
argname = Py.Str(Py.GetItem(arg, "name"))
157+
If Not Py.Var(Py.GetItem(arg, "range")) Then
158+
f.WriteLine sTab + "If TypeOf " + argname + " Is Range Then " + argname + " = " + argname + ".Value2"
159+
End If
160+
dims = Py.Var(Py.GetItem(arg, "dims"))
161+
marshal = Py.Str(Py.GetItem(arg, "marshal"))
162+
If dims <> -1 Or marshal = "nparray" Or marshal = "list" Then
163+
f.WriteLine sTab + "If Not TypeOf " + argname + " Is Object Then"
164+
If dims <> -1 Then
165+
f.WriteLine sTab + sTab + argname + " = NDims(" + argname + ", " + CStr(dims) + ")"
166+
End If
167+
If marshal = "nparray" Then
168+
dtype = Py.Var(Py.GetItem(arg, "dtype"))
169+
If IsNull(dtype) Then
170+
f.WriteLine sTab + sTab + "Set " + argname + " = Py.Call(Py.Module(""numpy""), ""array"", Py.Tuple(" + argname + "))"
171+
Else
172+
f.WriteLine sTab + sTab + "Set " + argname + " = Py.Call(Py.Module(""numpy""), ""array"", Py.Tuple(" + argname + ", """ + dtype + """))"
173+
End If
174+
ElseIf marshal = "list" Then
175+
f.WriteLine sTab + sTab + "Set " + argname + " = Py.Call(Py.Eval(""lambda t: [ list(x) if isinstance(x, tuple) else x for x in t ] if isinstance(t, tuple) else t""), Py.Tuple(" + argname + "))"
176+
End If
177+
f.WriteLine sTab + "End If"
178+
End If
179+
End If
180+
Next arg
181+
182+
f.Write sTab + "Set args = Py.Tuple("
183+
first = True
184+
For Each arg In Py.GetItem(xlfunc, "args")
185+
If Not first Then f.Write ", "
186+
If Not Py.Bool(Py.GetItem(arg, "vba")) Then
187+
f.Write Py.Str(Py.GetItem(arg, "name"))
188+
Else
189+
f.Write Py.Str(Py.GetItem(arg, "vba"))
190+
End If
191+
first = False
192+
Next arg
193+
f.WriteLine ")"
194+
195+
If Py.Bool(Py.GetItem(xlfunc, "xlwings")) Then
196+
f.WriteLine sTab + "Py.SetAttr Py.GetAttr(Py.Module(""xlwings""), ""xlplatform""), ""xl_app_latest"", Application"
197+
f.WriteLine sTab + "Py.SetAttr Py.Module(""xlwings.main""), ""xl_workbook_latest"", ThisWorkbook"
198+
End If
199+
200+
f.WriteLine sTab + "Set xlpy = Py.Module(""xlpython"")"
201+
f.WriteLine sTab + "Set script = Py.Call(xlpy, ""udf_script"", Py.Tuple(PyScriptPath))"
202+
f.WriteLine sTab + "Set func = Py.GetItem(script, """ + fname + """)"
203+
If ftype = "Sub" Then
204+
f.WriteLine sTab + "Py.Call func, args"
205+
Else
206+
f.WriteLine sTab + "Set " + fname + " = Py.Call(func, args)"
207+
marshal = Py.Str(Py.GetItem(xlret, "marshal"))
208+
Select Case marshal
209+
Case "auto"
210+
f.WriteLine sTab + "If TypeOf Application.Caller Is Range Then " + fname + " = Py.Var(" + fname + ", " + Py.Str(Py.GetItem(xlret, "lax")) + ")"
211+
Case "var"
212+
f.WriteLine sTab + fname + " = Py.Var(" + fname + ", " + Py.Str(Py.GetItem(xlret, "lax")) + ")"
213+
Case "str"
214+
f.WriteLine sTab + fname + " = Py.Str(" + fname + ")"
215+
End Select
216+
End If
217+
218+
If ftype = "Function" Then
219+
f.WriteLine sTab + "Exit " + ftype
220+
f.WriteLine "failed:"
221+
f.WriteLine sTab + fname + " = Err.Description"
222+
End If
223+
f.WriteLine "End " + ftype
224+
f.WriteLine
225+
End If
226+
Next svar
227+
f.Close
228+
229+
On Error GoTo not_present
230+
wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents("xlpython_udfs")
231+
not_present:
232+
On Error GoTo 0
233+
wb.VBProject.VBComponents.Import filename
234+
235+
For Each svar In Py.Call(scriptVars, "values")
236+
If Py.HasAttr(svar, "__xlfunc__") Then
237+
Set xlfunc = Py.GetAttr(svar, "__xlfunc__")
238+
Set xlret = Py.GetItem(xlfunc, "ret")
239+
Set xlargs = Py.GetItem(xlfunc, "args")
240+
fname = Py.Str(Py.GetItem(xlfunc, "name"))
241+
fdoc = Py.Str(Py.GetItem(xlret, "doc"))
242+
nArgs = 0
243+
For Each arg In xlargs
244+
If Not Py.Bool(Py.GetItem(arg, "vba")) Then nArgs = nArgs + 1
245+
Next arg
246+
If nArgs > 0 And Application.Version >= 14 Then
247+
ReDim argdocs(1 To WorksheetFunction.Max(1, nArgs)) As String
248+
nArgs = 0
249+
For Each arg In xlargs
250+
If Not Py.Bool(Py.GetItem(arg, "vba")) Then
251+
nArgs = nArgs + 1
252+
argdocs(nArgs) = Py.Str(Py.GetItem(arg, "doc"))
253+
End If
254+
Next arg
255+
XLPMacroOptions2010 "'" + wb.name + "'!" + fname, fdoc, argdocs
256+
Else
257+
Application.MacroOptions "'" + wb.name + "'!" + fname, Description:=fdoc
258+
End If
259+
End If
260+
Next svar
261+
262+
'MsgBox "Import successful!"
263+
End Sub
264+
265+
266+

0 commit comments

Comments
 (0)