Sub TurnOffSubDataSheets()
Dim MyDB As DAO.Database
Dim MyProperty As DAO.Property
Dim propName As String, propVal As String, rplpropValue As String
Dim propType As Integer, i As Integer
Dim intCount As Integer
On Error GoTo tagError
Set MyDB = CurrentDb
propName = "SubDataSheetName"
propType = 10
propVal = "[None]"
rplpropValue = "[Auto]"
intCount = 0
For i = 0 To MyDB.TableDefs.Count - 1
If (MyDB.TableDefs(i).Attributes And dbSystemObject) = 0 Then
If MyDB.TableDefs(i).Properties(propName).Value = rplpropValue Then
MyDB.TableDefs(i).Properties(propName).Value = propVal
intCount = intCount + 1
End If
End If
tagFromErrorHandling:
Next i
MyDB.Close
If intCount > 0 Then
MsgBox "The " & propName & " value for " & intCount & " non-system tables has been updated to " & propVal & "."
End If
Exit Sub
tagError:
If Err.Number = 3270 Then
Set MyProperty = MyDB.TableDefs(i).CreateProperty(propName)
MyProperty.Type = propType
MyProperty.Value = propVal
MyDB.TableDefs(i).Properties.Append MyProperty
intCount = intCount + 1
Resume tagFromErrorHandling
Else
MsgBox Err.Description & vbCrLf & vbCrLf & " in TurnOffSubDataSheets routine."
End If
続きを読む

ISO再作成
http://www.vwnet.jp/Windows/WS16/2017070901/2017071803/ReconstructionISO.htm

WindowsでISOファイルを標準機能で作成できる?
https://blog.putise.com/windows%E3%81%A7iso%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E6%A8%99%E6%BA%96%E6%A9%9F%E8%83%BD%E3%81%A7%E4%BD%9C%E6%88%90%E3%81%A7%E3%81%8D%E3%82%8B%EF%BC%9F/

'Option Explicit

'--------------------------------------------------------------------------------
' HTTP通信用クラス。
'--------------------------------------------------------------------------------

' HTTP通信用オブジェクト
Private httpObj As Object

'--------------------------------------------------------------------------------
' コンストラクタ
'--------------------------------------------------------------------------------
Public Sub Class_Initialize()
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2に対応
End Sub
Print
'--------------------------------------------------------------------------------
' デストラクタ
'--------------------------------------------------------------------------------
Public Sub Class_Terminate()
    Set httpObj = Nothing
End Sub
Print
'--------------------------------------------------------------------------------
' 引数のURLにPostメソッドで送信する。
'
' url:URL文字列。
' urlParams:URLパラメーター。
' return:レスポンスの文字列。
'--------------------------------------------------------------------------------
Public Function PostContents(url As String, urlParams As String) As String
    Dim buf As String
    Dim httpObj As Object
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2に対応
    httpObj.Open "POST", url, False
    httpObj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    httpObj.send (urlParams)

    ' readyState=4で読み込みが完了
    Do While httpObj.readyState < 4
        DoEvents
    Loop

    Dim statusCode As Integer
    statusCode = httpObj.Status

    ' HTTPのステータスコードが200(OK)以外であれば、ステータスコードなどを返す。
    If (statusCode = 200) Then
        'PostContents = httpObj.responseText ' レスポンスの文字コードがShift_JIS(MS932)の時はこちらを使う。
        'PostContents = StrConv(httpObj.responsebody, vbUnicode)
        Set stm = CreateObject("ADODB.Stream")
        stm.Type = 1   'バイナリモード
        stm.Open
        stm.Write httpObj.responseBody  'バイナリを書き込み
        stm.Position = 0  '先頭に戻してから
        stm.Type = 2   'テキストモードに変更
        stm.Charset = "utf-8"
        strResult = stm.ReadText(-1)   'データ全体を読み込む
        stm.Close
        'MsgBox strResult
        
        '国を切り出す
        buf = InStr(strResult, "Country:")
        buf2 = InStr(buf, strResult, "(")
        buf3 = InStr(buf2, strResult, ")")
        
        
        PostContents = Mid(strResult, buf2 + 1, buf3 - buf2 - 1)
    Else
        buf = "HTTP StatusCode:" & statusCode & ", HTTP StatusText:" & httpObj.statusText
        PostContents = buf
    End If
End Function



Public Function PostContents_new(url As String, urlParams As String) As String
    Dim buf As String
    Dim httpObj As Object
    Dim strResult As Variant
    
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2に対応
    httpObj.Open "POST", url, False
    httpObj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   httpObj.send ("inServer=" & urlParams)
    'httpObj.send (urlParams)

    ' readyState=4で読み込みが完了
    Do While httpObj.readyState < 4
        DoEvents
    Loop

    Dim statusCode As Integer
    statusCode = httpObj.Status

    ' HTTPのステータスコードが200(OK)以外であれば、ステータスコードなどを返す。
    If (statusCode = 200) Then
        'PostContents = httpObj.responseText ' レスポンスの文字コードがShift_JIS(MS932)の時はこちらを使う。
        'PostContents = StrConv(httpObj.responsebody, vbUnicode)
        Set stm = CreateObject("ADODB.Stream")
        stm.Type = 1   'バイナリモード
        stm.Open
        stm.Write httpObj.responseBody  'バイナリを書き込み
        stm.Position = 0  '先頭に戻してから
        stm.Type = 2   'テキストモードに変更
        stm.Charset = "utf-8"
        strResult = stm.ReadText(-1)   'データ全体を読み込む
        stm.Close
        'MsgBox strResult
        Debug.Print Len(strResult)
        
        '国を切り出す
        buf = InStr(strResult, "Country")
        If buf = 0 Then
            buf = InStr(strResult, "country")
        End If
            
        buf2 = InStr(buf, strResult, "(")
        buf3 = InStr(buf2, strResult, ")")
        
        
       PostContents_new = Mid(strResult, buf2 + 1, buf3 - buf2 - 1)
       'PostContents_new = strResult
    Else
        buf = "HTTP StatusCode:" & statusCode & ", HTTP StatusText:" & httpObj.statusText
        PostContents_new = buf
    End If
End Function

↑このページのトップヘ