2 Messages
Digest #4733
2a
Re: Cek file open di server apakah dibuka dikomputer sendiri atau di by "Mr. Kid" nmkid.family@ymail.com
Messages
Thu Mar 14, 2019 5:57 pm (PDT) . Posted by:
"Mr. Kid" nmkid.family@ymail.com
Public Sub BukaFile(Optional sFile As String, Optional sPwdOpen As String =
vbNullString)
Dim sMsgTxt As String, sMsgTitle As String, lMsg As Long, lTry As Long,
wbkF As Workbook
sMsgTxt = "Pembukaan ke-"
sMsgTitle = "Buka File"
lMsg = 20
If Len(sFile) * Len(Dir(sFile, vbNormal)) = 0 Then
MsgBox "File tidak ada atau tidak dapat di akses.", vbExclamation,
sMsgTitle
Exit Sub
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Keluar
Ulangi:
lTry = lTry + 1
Set wbkF = Workbooks.Open(sFile, 0, True, Password:=sPwdOpen,
IgnoreReadOnlyRecommended:=True, Notify:=False)
wbkF.ChangeFileAccess xlReadWrite, Notify:=False
If wbkF.ReadOnly Then
wbkF.Close False
If lTry Mod lMsg > 0 Then GoTo Ulangi
If MsgBox(sMsgTxt & lTry, vbExclamation + vbRetryCancel +
vbDefaultButton2, sMsgTitle & " : Read Only") = vbRetry Then GoTo Ulangi
End If
Keluar:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Err.Clear
On Error GoTo 0
End Sub
Cara pakai :
BukaFile "path\file.ekstension","pwd"
On Wed, Mar 13, 2019 at 11:46 PM Tio Adi Bayu Adjie tio.adjie@ptssb.co.id
[belajar-excel] <belajar-excel@yahoogroups.com> wrote:
>
>
> Salam Be-Exceller,
>
> Saya membuat aplikasi untuk multi user dimana file tersebut diisi oleh
> beberapa user. File itu ada di server (network). Tapi terdapat kendala
> yaitu mengetahui apakah file sudah tertutup/tidak. Itu karena file itu
> digunakan oleh semua orang. Jadi saya ingin mengetahui apakah file itu
> sudah tertutup atau tidak. Kalau file di server itu tertutup, maka saya
> buka file itu dan update data di file di server tersebut. Dan setelah
> update data, saya tutup file kembali secepatnya karena akan digunakan user
> lain.
>
> Saya sudah buat code tapi masih ada error yaitu "…..File is currently in
> use. Please try again". Code itu kadang-kadang error disaat *open file*,
> dan kadang-kala error di saat *file itu ditutup* kembali.
>
> Code yang sudah saya buat adalah :
>
>
>
> Dim w as long
>
> Dim src as workbook
>
> Dim ikonfirmasi as integer
>
> Dim namafile as string,fname as string
>
>
>
> fname = Dataku.Cells(1, 40).value
>
> namafile ="DataGudang.xlsx"
>
>
>
> Ulangi_Buka:
>
> w = 0
>
> Err.Clear
>
> On Error Resume Next
>
> *Set src = Workbooks.Open(fname, True, False, , "1") *'--------à *Kadang
> suka error yang bunyinya : \\Folder_Server\FolderFile\DataGudang.xlsx is
> currently in use. Please try again later. Catatan : password file : 1*
>
> If Err.Number <> 0 Or src Is Nothing Then
>
> On Error GoTo 0
>
> End If
>
> On Error Resume Next
>
> If src.ReadOnly Then
>
> Err.Clear
>
> w = w + 1
>
> If w >= 5000 Then
>
> ikonfirmasi = MsgBox("Saya telah cek sebanyak " & w & ". Apakah
> anda ingin melanjutkan ?", vbQuestion + vbYesNo, "Konfirmasi")
>
> If ikonfirmasi = vbYes Then
>
> GoTo Ulangi_Buka
>
> Else
>
> src.Close False
>
> Exit Sub
>
> End If
>
> Else
>
> *Workbooks(namafile)..Close False '--------**à Kadang suka error yang
> bunyinya sama seperti diatas : : \\Folder_Server\FolderFile\DataGudang.xlsx
> is currently in use. Please try again later*
>
> GoTo Ulangi_Buka
>
> End If
>
> End If
>
> '====
>
> Mohon petunjuknya, bagaimana bisa mengatasi error tersebut ?
>
>
>
> Terima kasih atas bimbingannya. Semoga Allah SWT membalas kebaikan
> teman-teman. Amiin…
>
> Tio
>
>
>
>
>
vbNullString)
Dim sMsgTxt As String, sMsgTitle As String, lMsg As Long, lTry As Long,
wbkF As Workbook
sMsgTxt = "Pembukaan ke-"
sMsgTitle = "Buka File"
lMsg = 20
If Len(sFile) * Len(Dir(sFile, vbNormal)) = 0 Then
MsgBox "File tidak ada atau tidak dapat di akses.", vbExclamation,
sMsgTitle
Exit Sub
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Keluar
Ulangi:
lTry = lTry + 1
Set wbkF = Workbooks.Open(sFile, 0, True, Password:=sPwdOpen,
IgnoreReadOnlyRecommended:=True, Notify:=False)
wbkF.ChangeFileAccess xlReadWrite, Notify:=False
If wbkF.ReadOnly Then
wbkF.Close False
If lTry Mod lMsg > 0 Then GoTo Ulangi
If MsgBox(sMsgTxt & lTry, vbExclamation + vbRetryCancel +
vbDefaultButton2, sMsgTitle & " : Read Only") = vbRetry Then GoTo Ulangi
End If
Keluar:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Err.Clear
On Error GoTo 0
End Sub
Cara pakai :
BukaFile "path\file.ekstension","pwd"
On Wed, Mar 13, 2019 at 11:46 PM Tio Adi Bayu Adjie tio.adjie@ptssb.co.id
[belajar-excel] <belajar-excel@yahoogroups.com> wrote:
>
>
> Salam Be-Exceller,
>
> Saya membuat aplikasi untuk multi user dimana file tersebut diisi oleh
> beberapa user. File itu ada di server (network). Tapi terdapat kendala
> yaitu mengetahui apakah file sudah tertutup/tidak. Itu karena file itu
> digunakan oleh semua orang. Jadi saya ingin mengetahui apakah file itu
> sudah tertutup atau tidak. Kalau file di server itu tertutup, maka saya
> buka file itu dan update data di file di server tersebut. Dan setelah
> update data, saya tutup file kembali secepatnya karena akan digunakan user
> lain.
>
> Saya sudah buat code tapi masih ada error yaitu "…..File is currently in
> use. Please try again". Code itu kadang-kadang error disaat *open file*,
> dan kadang-kala error di saat *file itu ditutup* kembali.
>
> Code yang sudah saya buat adalah :
>
>
>
> Dim w as long
>
> Dim src as workbook
>
> Dim ikonfirmasi as integer
>
> Dim namafile as string,fname as string
>
>
>
> fname = Dataku.Cells(
>
> namafile ="DataGudang.xlsx"
>
>
>
> Ulangi_Buka:
>
> w = 0
>
> Err.Clear
>
> On Error Resume Next
>
> *Set src = Workbooks.Open(
> suka error yang bunyinya : \\Folder_
> currently in use. Please try again later. Catatan : password file : 1*
>
> If Err.Number <> 0 Or src Is Nothing Then
>
> On Error GoTo 0
>
> End If
>
> On Error Resume Next
>
> If src.ReadOnly Then
>
> Err.Clear
>
> w = w + 1
>
> If w >= 5000 Then
>
> ikonfirmasi = MsgBox("
> anda ingin melanjutkan ?", vbQuestion + vbYesNo, "Konfirmasi&qu
>
> If ikonfirmasi = vbYes Then
>
> GoTo Ulangi_Buka
>
> Else
>
> src.Close False
>
> Exit Sub
>
> End If
>
> Else
>
> *Workbooks(namafile
> bunyinya sama seperti diatas : : \\Folder_
> is currently in use. Please try again later*
>
> GoTo Ulangi_Buka
>
> End If
>
> End If
>
> '====
>
> Mohon petunjuknya, bagaimana bisa mengatasi error tersebut ?
>
>
>
> Terima kasih atas bimbingannya. Semoga Allah SWT membalas kebaikan
> teman-teman. Amiin…
>
> Tio
>
>
>
>
>
Thu Mar 14, 2019 6:03 pm (PDT) . Posted by:
"Mr. Kid" nmkid.family@ymail.com
Public Sub BukaFile(Optional sFile As String, Optional sPwdOpen As String =
vbNullString)
Dim sMsgTxt As String, sMsgTitle As String, lMsg As Long, lTry As Long,
wbkF As Workbook
sMsgTxt = "Pembukaan ke-"
sMsgTitle = "Buka File"
lMsg = 20
If Len(sFile) * Len(Dir(sFile, vbNormal)) = 0 Then
MsgBox "File tidak ada atau tidak dapat di akses.", vbExclamation,
sMsgTitle
Exit Sub
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Keluar
Ulangi:
lTry = lTry + 1
Set wbkF = Workbooks.Open(sFile, 0, True, Password:=sPwdOpen,
IgnoreReadOnlyRecommended:=True, Notify:=False)
wbkF.ChangeFileAccess xlReadWrite, Notify:=False
If wbkF.ReadOnly Then
wbkF.Close False
If lTry Mod lMsg > 0 Then GoTo Ulangi
If MsgBox(sMsgTxt & lTry, vbExclamation + vbRetryCancel +
vbDefaultButton2, sMsgTitle & " : Read Only") = vbRetry Then GoTo Ulangi
End If
Keluar:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Err.Clear
On Error GoTo 0
End Sub
Cara pakai :
BukaFile "path\file.extension","Pwd"
On Thu, Mar 14, 2019 at 5:46 AM Tio Adi Bayu Adjie tio.adjie@ptssb.co.id
[belajar-excel] <belajar-excel@yahoogroups.com> wrote:
>
>
> Dear Be-Exceller,
>
> Saya mau cek apakah file di server dibuka oleh orang lain atau dibuka
> dikomputer sendiri. File itu ada di server. Saya sudah bikin code nya tapi
> kok gak bisa ya ? Mohon bimbingannya.
>
>
>
> Ini code saya :
>
>
>
> Public function sFileAdaAccess(fname) as Boolean
>
> sFileAdaAccess = True
>
> If IsFileOpen(fname) = True Then
>
> Set wbbook = Workbooks(fname)
>
>
>
> If Not wbbook.ReadOnly = True Then
>
> MsgBox "Silahkan ditutup dulu File Master",
> vbExclamation, "File master terbuka"
>
> sFileAdaAccess = false
>
> Exit Function
>
> Else
>
> sFileAdaAccess = True
>
> End If
>
> Set wbbook = Nothing
>
> 'End If
>
>
>
> Public Function IsFileOpen(filename As String) As Boolean
>
> Dim filenum As Integer
>
> Dim errnum As Integer
>
>
>
> On Error Resume Next ' Turn error checking off..
>
>
>
> '''''''''''''''''''''''''''''''''''''''''''
>
> ' If we were passed in an empty string,
>
> ' there is no file to test so return FALSE.
>
> '''''''''''''''''''''''''''''''''''''''''''
>
> If filename = vbNullString Then
>
> IsFileOpen = False
>
> Exit Function
>
> End If
>
>
>
> '''''''''''''''''''''''''''''''
>
> ' If the file doesn't exist,
>
> ' it isn't open so get out now.
>
> '''''''''''''''''''''''''''''''
>
> If Dir(filename) = vbNullString Then
>
> IsFileOpen = False
>
> Exit Function
>
> End If
>
> ''''''''''''''''''''''''''
>
> ' Get a free file number.
>
> ''''''''''''''''''''''''''
>
> filenum = FreeFile()
>
> '''''''''''''''''''''''''''
>
> ' Attempt to open the file
>
> ' and lock it.
>
> '''''''''''''''''''''''''''
>
> Err.Clear
>
> Open filename For Input Lock Read As #filenum
>
> ''''''''''''''''''''''''''''''''''''''
>
> ' Save the error number that occurred.
>
> ''''''''''''''''''''''''''''''''''''''
>
> errnum = Err.Number
>
> On Error GoTo 0 ' Turn error checking back on.
>
> Close #filenum ' Close the file.
>
> ''''''''''''''''''''''''''''''''''''
>
> ' Check to see which error occurred.
>
> ''''''''''''''''''''''''''''''''''''
>
> Select Case errnum
>
> Case 0
>
> '''''''''''''''''''''''''''''''''''''''''''
>
> ' No error occurred.
>
> ' File is NOT already open by another user.
>
> '''''''''''''''''''''''''''''''''''''''''''
>
> IsFileOpen = False
>
>
>
> Case 70
>
> ''''''''&#
vbNullString)
Dim sMsgTxt As String, sMsgTitle As String, lMsg As Long, lTry As Long,
wbkF As Workbook
sMsgTxt = "Pembukaan ke-"
sMsgTitle = "Buka File"
lMsg = 20
If Len(sFile) * Len(Dir(sFile, vbNormal)) = 0 Then
MsgBox "File tidak ada atau tidak dapat di akses.", vbExclamation,
sMsgTitle
Exit Sub
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Keluar
Ulangi:
lTry = lTry + 1
Set wbkF = Workbooks.Open(sFile, 0, True, Password:=sPwdOpen,
IgnoreReadOnlyRecommended:=True, Notify:=False)
wbkF.ChangeFileAccess xlReadWrite, Notify:=False
If wbkF.ReadOnly Then
wbkF.Close False
If lTry Mod lMsg > 0 Then GoTo Ulangi
If MsgBox(sMsgTxt & lTry, vbExclamation + vbRetryCancel +
vbDefaultButton2, sMsgTitle & " : Read Only") = vbRetry Then GoTo Ulangi
End If
Keluar:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Err.Clear
On Error GoTo 0
End Sub
Cara pakai :
BukaFile "path\file.extension","Pwd"
On Thu, Mar 14, 2019 at 5:46 AM Tio Adi Bayu Adjie tio.adjie@ptssb.co.id
[belajar-excel] <belajar-excel@yahoogroups.com> wrote:
>
>
> Dear Be-Exceller,
>
> Saya mau cek apakah file di server dibuka oleh orang lain atau dibuka
> dikomputer sendiri. File itu ada di server. Saya sudah bikin code nya tapi
> kok gak bisa ya ? Mohon bimbingannya.
>
>
>
> Ini code saya :
>
>
>
> Public function sFileAdaAccess(
>
> sFileAdaAccess = True
>
> If IsFileOpen(fname) = True Then
>
> Set wbbook = Workbooks(fname)
>
>
>
> If Not wbbook.ReadOnly = True Then
>
> MsgBox "Silahkan ditutup dulu File Master"
> vbExclamation, "File master terbuka"
>
> sFileAdaAccess = false
>
> Exit Function
>
> Else
>
> sFileAdaAccess = True
>
> End If
>
> Set wbbook = Nothing
>
> 'End If
>
>
>
> Public Function IsFileOpen(filename As String) As Boolean
>
> Dim filenum As Integer
>
> Dim errnum As Integer
>
>
>
> On Error Resume Next ' Turn error checking off..
>
>
>
> ''&#
>
> ' If we were passed in an empty string,
>
> ' there is no file to test so return FALSE.
>
> ''&#
>
> If filename = vbNullString Then
>
> IsFileOpen = False
>
> Exit Function
>
> End If
>
>
>
> ''&#
>
> ' If the file doesn't exist,
>
> ' it isn't open so get out now.
>
> ''&#
>
> If Dir(filename) = vbNullString Then
>
> IsFileOpen = False
>
> Exit Function
>
> End If
>
> ''&#
>
> ' Get a free file number.
>
> ''&#
>
> filenum = FreeFile()
>
> ''&#
>
> ' Attempt to open the file
>
> ' and lock it.
>
> ''&#
>
> Err.Clear
>
> Open filename For Input Lock Read As #filenum
>
> ''&#
>
> ' Save the error number that occurred.
>
> ''&#
>
> errnum = Err.Number
>
> On Error GoTo 0 ' Turn error checking back on.
>
> Close #filenum ' Close the file.
>
> ''&#
>
> ' Check to see which error occurred.
>
> ''&#
>
> Select Case errnum
>
> Case 0
>
> ''&#
>
> ' No error occurred.
>
> ' File is NOT already open by another user.
>
> ''&#
>
> IsFileOpen = False
>
>
>
> Case 70
>
> ''&#