Excel macros (32 bit excel) in 64 bit - excel

Question

Im not good in Visual Basic but I have task to make macros from 32 bit windows excel available on 64 bit window :)
The task is to make EMF from Excel page - I`ve already changed "function" to "PtrSafe function" and "olepro32.dll" to "oleaut32.dll" but code is running with error - RunTime error "380" Invalid property value
Sub UpdateRtLogsandEMF()
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
Application.ScreenUpdating = False
This.Worksheets("TempSQL").Visible = xlSheetVisible
This.Worksheets("TempLog").Visible = xlSheetVisible
This.Worksheets("TempLog").Select
Set cn = New ADODB.Connection
sCon = This.Worksheets("TempSQL").Cells(1, 1)
cn.Open sCon
DrillDepthIndex = This.Worksheets("TempLog").Cells(1, 157)
DrillDepthIndex = "'" & DrillDepthIndex & "'"
WellPathIndex = This.Worksheets("TempLog").Cells(1, 154)
WellPathIndex = "'" & WellPathIndex & "'"
Set rs = New ADODB.Recordset
sql_query = "SELECT Depth FROM GENDATAINDEX WHERE GenDataSetId = " & DrillDepthIndex & "ORDER BY Time DESC"
rs.Open sql_query, cn
On Error Resume Next
sss = rs.Fields(0)
If sss = "" Then
This.Worksheets("Logs RT").Cells(14, 19) = ""
Else
This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
End If
'This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
Date1 = Format(Now, "yyyy.mm.dd")
Day1 = Right(Date1, 2)
Year1 = Left(Date1, 4)
Month1 = Mid(Date1, 6, 2)
If This.Worksheets("TempLog").Cells(1, 210) = "RUS" Then
dfd = 43
Else
dfd = 42
End If
This.Worksheets("Logs RT").Cells(11, 15) = Day1 & " " & This.Worksheets("Logs RT").Cells(Month1, dfd) & " " & Year1
This.Worksheets("Logs RT").Cells(12, 15) = Format(Now, "HH:mm")
This.Worksheets("Logs RT").Select
Set rs = New ADODB.Recordset
sql_query = "SELECT SRSP_S_VDEPTH FROM SURVEY_STATION WHERE PATH_IDENTIFIER = " & WellPathIndex & " ORDER BY SRSP_TIME DESC"
rs.Open sql_query, cn
On Error Resume Next
sss = rs.Fields(0)
If sss = "" Then
This.Worksheets("Logs RT").Cells(14, 62) = ""
Else
This.Worksheets("Logs RT").Cells(14, 62) = Round(rs.Fields(0), 2)
End If
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_MD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 2), Cells(67, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_TVD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 45), Cells(67, 75)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
This.Worksheets("Logs RT").Select
This.Worksheets("TempSQL").Visible = xlSheetHidden
This.Worksheets("TempLog").Visible = xlSheetHidden
Application.ScreenUpdating = True
End Sub
Sub MakeRtLogsEMF()
Application.ScreenUpdating = False
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
Set This = ThisWorkbook
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_MD.emf"
'Get the type of bitmap
lPicType = xlPicture
'Copy a picture to the clipboard
This.Worksheets("Logs RT").Range(Cells(2, 2), Cells(67, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
'Retrieve the picture from the clipboard...
Set oPic = PastePicture(lPicType)
'... and save it to the file
SavePicture oPic, vFile
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_TVD.emf"
'Get the type of bitmap
lPicType = xlPicture
'Copy a picture to the clipboard
This.Worksheets("Logs RT").Range(Cells(2, 45), Cells(67, 75)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
'Retrieve the picture from the clipboard...
Set oPic = PastePicture(lPicType)
'... and save it to the file
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
'
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
Application.ScreenUpdating = True
End Sub
Sub MakeTailEMF()
Application.ScreenUpdating = False
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
Set This = ThisWorkbook
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_tail.emf"
'Get the type of bitmap
lPicType = xlPicture
'Copy a picture to the clipboard
This.Worksheets("Logs RT").Range(Cells(70, 2), Cells(78, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
'Retrieve the picture from the clipboard...
Set oPic = PastePicture(lPicType)
'... and save it to the file
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
'
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
Application.ScreenUpdating = True
End Sub
Sub UpdateRtLogsandEMF_woDepth()
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
Application.ScreenUpdating = False
This.Worksheets("TempSQL").Visible = xlSheetVisible
This.Worksheets("TempLog").Visible = xlSheetVisible
This.Worksheets("TempLog").Select
Set cn = New ADODB.Connection
sCon = This.Worksheets("TempSQL").Cells(1, 1)
cn.Open sCon
'DrillDepthIndex = This.Worksheets("TempLog").Cells(1, 157)
'DrillDepthIndex = "'" & DrillDepthIndex & "'"
'WellPathIndex = This.Worksheets("TempLog").Cells(1, 154)
'WellPathIndex = "'" & WellPathIndex & "'"
'Set rs = New ADODB.Recordset
'sql_query = "SELECT Depth FROM GENDATAINDEX WHERE GenDataSetId = " & DrillDepthIndex & "ORDER BY Time DESC"
'rs.Open sql_query, cn
'On Error Resume Next
'sss = rs.Fields(0)
'If sss = "" Then
'This.Worksheets("Logs RT").Cells(14, 19) = ""
'Else
'This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
'End If
'This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
Date1 = Format(Now, "yyyy.mm.dd")
Day1 = Right(Date1, 2)
Year1 = Left(Date1, 4)
Month1 = Mid(Date1, 6, 2)
This.Worksheets("Logs RT").Cells(11, 15) = Day1 & " " & This.Worksheets("Logs RT").Cells(Month1, 43) & " " & Year1
This.Worksheets("Logs RT").Cells(12, 15) = Format(Now, "HH:mm")
This.Worksheets("Logs RT").Select
'Set rs = New ADODB.Recordset
'sql_query = "SELECT SRSP_S_VDEPTH FROM SURVEY_STATION WHERE PATH_IDENTIFIER = " & WellPathIndex & " ORDER BY SRSP_TIME DESC"
'rs.Open sql_query, cn
'On Error Resume Next
'sss = rs.Fields(0)
'If sss = "" Then
'This.Worksheets("Logs RT").Cells(14, 62) = ""
'Else
'This.Worksheets("Logs RT").Cells(14, 62) = Round(rs.Fields(0), 2)
'End If
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_MD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 2), Cells(67, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_TVD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 45), Cells(67, 75)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
This.Worksheets("Logs RT").Select
This.Worksheets("TempSQL").Visible = xlSheetHidden
This.Worksheets("TempLog").Visible = xlSheetHidden
Application.ScreenUpdating = True
End Sub
Debugger stops at "SavePicture oPic, vFile"