Sub RunSAP_MB51_WithSSO()
Dim SapGui As Object, App As Object, Conn As Object, Session As Object
Dim WshShell As Object
Dim sapPath As String
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, cell As Range
Dim searchString As String
Dim rowNumber As Long
Dim exportPath As String, exportFile As String, logFile As String
Dim appWorkbookCount As Long
Dim fNum As Integer
Dim timeoutSeconds As Long, startTime As Double
Dim grrWorkbook As Workbook
Dim wbTest As Workbook
On Error GoTo ErrHandler
' === Performance Optimization ===
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' === Dynamic Export Path ===
exportPath = Environ("USERPROFILE") & "\OneDrive - BASF\Desktop"
exportFile = "GRRMPM.XLSX"
logFile = exportPath & "\SAP_Export_Log.txt"
' === Open Log File ===
fNum = FreeFile
Open logFile For Append As #fNum
Print #fNum, "----- Process Started: " & Now & " -----"
Print #fNum, "Target System: Cobalt - Z2L (Prod) Link"
Print #fNum, "Using SSO (Single Sign-On), no credentials required."
' === Check if SAP GUI is already running ===
Print #fNum, "Checking for existing SAP GUI session..."
Set SapGui = Nothing
On Error Resume Next
Set SapGui = GetObject("SAPGUI")
On Error GoTo ErrHandler
If SapGui Is Nothing Then
Print #fNum, "SAP GUI not found. Launching SAP Logon..."
' --- Define SAP Logon executable path ---
sapPath = "C:\Program Files (x86)\SAP\FrontEnd\SAPgui\saplogon.exe"
If Dir(sapPath) = "" Then
MsgBox "SAP Logon executable not found at:" & vbCrLf & sapPath, vbCritical
Print #fNum, "ERROR: SAP Logon not found at " & sapPath
GoTo Cleanup
End If
' --- Launch SAP Logon ---
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run """" & sapPath & """", 1, False ' 启动 SAP Logon
Print #fNum, "Launched SAP Logon from: " & sapPath
' --- Wait for SAP GUI to initialize ---
Application.Wait Now + TimeSerial(0, 0, 5) ' 等待 5 秒让 GUI 启动
Set SapGui = GetObject("SAPGUI")
If SapGui Is Nothing Then
MsgBox "Failed to connect to SAP GUI after launch.", vbCritical
GoTo Cleanup
End If
Else
Print #fNum, "Existing SAP GUI detected."
End If
' === Get Scripting Engine ===
Set App = SapGui.GetScriptingEngine
If App Is Nothing Then
Print #fNum, "Scripting engine not available. Please enable scripting in SAP options."
MsgBox "Scripting is disabled. Go to SAP Logon → Options → Enable 'Scripting'.", vbCritical
GoTo Cleanup
End If
' === Connect to Target System via SSO ===
Print #fNum, "Connecting to system: Cobalt - Z2L (Prod) Link"
Set Conn = Nothing
On Error Resume Next
Set Conn = App.OpenConnection("Cobalt - Z2L (Prod) Link", True)
On Error GoTo ErrHandler
If Conn Is Nothing Then
MsgBox "Could not connect to 'Cobalt - Z2L (Prod) Link'." & vbCrLf & _
"Please verify the exact system name in SAP Logon.", vbCritical
Print #fNum, "ERROR: Connection failed. Check system name spelling/case."
GoTo Cleanup
End If
Print #fNum, "Connection established. Waiting for SSO login..."
' --- Wait for session to become active ---
timeoutSeconds = 60 ' SSO 可能需要时间
startTime = Timer
Do
DoEvents
Set Session = Nothing
On Error Resume Next
Set Session = Conn.Children(0)
On Error GoTo ErrHandler
If Not Session Is Nothing Then
' 检查是否已进入主界面（例如通过判断是否存在菜单栏）
If Not IsError(ExecuteSAPCommand(Session, "wnd[0]/mbar/menu[0]/text")) Then
Exit Do
End If
End If
If Timer - startTime > timeoutSeconds Then
Print #fNum, "Timeout waiting for SSO login to complete."
MsgBox "Login timed out. Please check network or SAP availability.", vbExclamation
GoTo Cleanup
End If
Application.Wait Now + TimeSerial(0, 0, 1) ' 每秒检查一次
Loop
Print #fNum, "SSO login successful. Session ready."
' === Start Transaction MB51 ===
Print #fNum, "Starting transaction MB51..."
Session.StartTransaction "MB51"
' Small delay for UI to stabilize
Application.Wait Now + TimeSerial(0, 0, 2)
' === Perform Navigation in MB51 ===
With Session
.FindById("wnd[0]/tbar[1]/btn[17]").Press ' Layout selection
.FindById("wnd[1]/tbar[0]/btn[6]").Press ' Execute
On Error Resume Next
With .FindById("wnd[1]/usr/cntlALV_CONTAINER_1/shellcont/shell")
If .rowCount > 2 Then
.CurrentCellRow = 2
.SelectedRows = "2"
.DoubleClickCurrentCell
Else
Print #fNum, "No data rows in ALV grid; proceeding anyway."
End If
End With
On Error GoTo ErrHandler
.FindById("wnd[0]/tbar[1]/btn[8]").Press ' Execute query
.FindById("wnd[0]/tbar[1]/btn[48]").Press ' Select layout
.FindById("wnd[0]/usr/cntlGRID1/shellcont/shell").CurrentCellColumn = "MAKTX"
.FindById("wnd[0]/usr/cntlGRID1/shellcont/shell").SelectedRows = "0"
.FindById("wnd[0]/usr/cntlGRID1/shellcont/shell").ContextMenu
.FindById("wnd[0]/usr/cntlGRID1/shellcont/shell").SelectContextMenuItem "&XXL" ' Export to Excel
End With
' === Handle Export Dialog ===
Print #fNum, "Exporting to Excel: " & exportPath & "\" & exportFile
With Session.FindById("wnd[1]")
.FindById("usr/ctxtDY_PATH").Text = exportPath
.FindById("usr/ctxtDY_FILENAME").Text = exportFile
.FindById("tbar[0]/btn[11]").Press ' Save
End With
' === Wait for Exported File to Open in Excel ===
appWorkbookCount = Application.Workbooks.Count
timeoutSeconds = 30
startTime = Timer
Do
DoEvents
If Timer - startTime > timeoutSeconds Then Exit Do
Loop While Application.Workbooks.Count = appWorkbookCount
If Application.Workbooks.Count > appWorkbookCount Then
Print #fNum, "Exported file opened successfully."
Else
Print #fNum, "Timeout waiting for GRRMPM.XLSX to open."
MsgBox "Export did not complete or file failed to open.", vbExclamation
GoTo Cleanup
End If
' === Reference the exported workbook ===
Set grrWorkbook = Nothing
For Each wbTest In Application.Workbooks
If wbTest.Name = "GRRMPM.XLSX" Then
Set grrWorkbook = wbTest
Exit For
End If
Next wbTest
If grrWorkbook Is Nothing Then
Print #fNum, "ERROR: Cannot find GRRMPM.XLSX after export."
GoTo Cleanup
End If
' === Open MPS25.XLSX ===
Dim mpsPath As String
mpsPath = exportPath & "\MPS25.XLSX"
If Dir(mpsPath) = "" Then
Print #fNum, "MPS25.XLSX not found at: " & mpsPath
MsgBox "MPS25.XLSX not found!", vbCritical
GoTo Cleanup
End If
Set wb = Workbooks.Open(mpsPath)
Set ws = wb.Sheets("BOH")
If ws Is Nothing Then
Print #fNum, "Sheet 'BOH' not found!"
GoTo Cleanup
End If
' === Find Row Before SAPdataend ===
searchString = "SAPdataend"
Set cell = ws.Columns("A:A").Find(What:=searchString, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
rowNumber = cell.Row - 1
Print #fNum, "Using range up to row " & rowNumber
Else
Print #fNum, "Marker 'SAPdataend' not found!"
MsgBox "Marker 'SAPdataend' not found!", vbExclamation
GoTo Cleanup
End If
' === Apply SUMIF Formula and Convert to Values ===
If rowNumber >= 2 Then
ws.Range("K2").FormulaR1C1 = "=SUMIF('" & grrWorkbook.Name & "'!C5,RC[-10],'" & grrWorkbook.Name & "'!C7)/2"
If rowNumber > 2 Then
ws.Range("K2").AutoFill Destination:=ws.Range("K2:K" & rowNumber)
End If
ws.Range("K2:K" & rowNumber).Value = ws.Range("K2:K" & rowNumber).Value
Print #fNum, "SUMIF formula applied and converted to values."
End If
Cleanup:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If fNum > 0 Then
Print #fNum, "Process Completed: " & Now
Print #fNum, "---------------------------------------------"
Close #fNum
End If
Exit Sub
ErrHandler:
Print #fNum, "RUNTIME ERROR [" & Err.Number & "] at line " & Erl & ": " & Err.Description
MsgBox "An error occurred. See log for details." & vbCrLf & "Error: " & Err.Description, vbCritical
Resume Cleanup
End Sub
' --- Helper Function: Safely execute SAP command without crashing on invalid ID ---
Function ExecuteSAPCommand(sess As Object, elementId As String) As Variant
On Error Resume Next
ExecuteSAPCommand = sess.FindById(elementId, False).Text
End Function
请精简上述代码，不需要仍和log 和 msg
最新发布
本文介绍了一种解决Excel中带有空格的文本型数字转换为数值型数据的方法，通过使用特定公式，成功实现了对数据的有效处理，以便进行数学运算。
扫一扫
3971
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
